diff options
Diffstat (limited to 'contrib')
266 files changed, 0 insertions, 87200 deletions
diff --git a/contrib/cc/README b/contrib/cc/README deleted file mode 100644 index 073b140e..00000000 --- a/contrib/cc/README +++ /dev/null @@ -1,20 +0,0 @@ - -cctac: congruence-closure for coq - -author: Pierre Corbineau, - Stage de DEA au LSV, ENS Cachan - Thèse au LRI, Université Paris Sud XI - -Files : - -- ccalgo.ml : congruence closure algorithm -- ccproof.ml : proof generation code -- cctac.ml4 : the tactic itself -- CCSolve.v : a small Ltac tactic based on congruence - -Known Bugs : the congruence tactic can fail due to type dependencies. - -Related documents: - Peter J. Downey, Ravi Sethi, and Robert E. Tarjan. - Variations on the common subexpression problem. - JACM, 27(4):758-771, October 1980. diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml deleted file mode 100644 index e67797e4..00000000 --- a/contrib/cc/ccalgo.ml +++ /dev/null @@ -1,884 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *) - -(* This file implements the basic congruence-closure algorithm by *) -(* Downey,Sethi and Tarjan. *) - -open Util -open Pp -open Goptions -open Names -open Term -open Tacmach -open Evd -open Proof_type - -let init_size=5 - -let cc_verbose=ref false - -let debug f x = - if !cc_verbose then f x - -let _= - let gdopt= - { optsync=true; - optname="Congruence Verbose"; - optkey=SecondaryTable("Congruence","Verbose"); - optread=(fun ()-> !cc_verbose); - optwrite=(fun b -> cc_verbose := b)} - in - declare_bool_option gdopt - -(* Signature table *) - -module ST=struct - - (* l: sign -> term r: term -> sign *) - - type t = {toterm:(int*int,int) Hashtbl.t; - tosign:(int,int*int) Hashtbl.t} - - let empty ()= - {toterm=Hashtbl.create init_size; - tosign=Hashtbl.create init_size} - - let enter t sign st= - if Hashtbl.mem st.toterm sign then - anomaly "enter: signature already entered" - else - Hashtbl.replace st.toterm sign t; - Hashtbl.replace st.tosign t sign - - let query sign st=Hashtbl.find st.toterm sign - - let rev_query term st=Hashtbl.find st.tosign term - - let delete st t= - try let sign=Hashtbl.find st.tosign t in - Hashtbl.remove st.toterm sign; - Hashtbl.remove st.tosign t - with - Not_found -> () - - let rec delete_set st s = Intset.iter (delete st) s - -end - -type pa_constructor= - { cnode : int; - arity : int; - args : int list} - -type pa_fun= - {fsym:int; - fnargs:int} - -type pa_mark= - Fmark of pa_fun - | Cmark of pa_constructor - -module PacMap=Map.Make(struct - type t=pa_constructor - let compare=Pervasives.compare end) - -module PafMap=Map.Make(struct - type t=pa_fun - let compare=Pervasives.compare end) - -type cinfo= - {ci_constr: constructor; (* inductive type *) - ci_arity: int; (* # args *) - ci_nhyps: int} (* # projectable args *) - -type term= - Symb of constr - | Product of sorts_family * sorts_family - | Eps of identifier - | Appli of term*term - | Constructor of cinfo (* constructor arity + nhyps *) - -type ccpattern = - PApp of term * ccpattern list (* arguments are reversed *) - | PVar of int - -type rule= - Congruence - | Axiom of constr * bool - | Injection of int * pa_constructor * int * pa_constructor * int - -type from= - Goal - | Hyp of constr - | HeqG of constr - | HeqnH of constr * constr - -type 'a eq = {lhs:int;rhs:int;rule:'a} - -type equality = rule eq - -type disequality = from eq - -type patt_kind = - Normal - | Trivial of types - | Creates_variables - -type quant_eq = - {qe_hyp_id: identifier; - qe_pol: bool; - qe_nvars:int; - qe_lhs: ccpattern; - qe_lhs_valid:patt_kind; - qe_rhs: ccpattern; - qe_rhs_valid:patt_kind} - -let swap eq : equality = - let swap_rule=match eq.rule with - Congruence -> Congruence - | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) - | Axiom (id,reversed) -> Axiom (id,not reversed) - in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} - -type inductive_status = - Unknown - | Partial of pa_constructor - | Partial_applied - | Total of (int * pa_constructor) - -type representative= - {mutable weight:int; - mutable lfathers:Intset.t; - mutable fathers:Intset.t; - mutable inductive_status: inductive_status; - class_type : Term.types; - mutable functions: Intset.t PafMap.t; - mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) - -type cl = Rep of representative| Eqto of int*equality - -type vertex = Leaf| Node of (int*int) - -type node = - {mutable clas:cl; - mutable cpath: int; - vertex:vertex; - term:term} - -type forest= - {mutable max_size:int; - mutable size:int; - mutable map: node array; - axioms: (constr,term*term) Hashtbl.t; - mutable epsilons: pa_constructor list; - syms:(term,int) Hashtbl.t} - -type state = - {uf: forest; - sigtable:ST.t; - mutable terms: Intset.t; - combine: equality Queue.t; - marks: (int * pa_mark) Queue.t; - mutable diseq: disequality list; - mutable quant: quant_eq list; - mutable pa_classes: Intset.t; - q_history: (identifier,int array) Hashtbl.t; - mutable rew_depth:int; - mutable changed:bool; - by_type: (types,Intset.t) Hashtbl.t; - mutable gls:Proof_type.goal Tacmach.sigma} - -let dummy_node = - {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); - cpath=min_int; - vertex=Leaf; - term=Symb (mkRel min_int)} - -let empty depth gls:state = - {uf= - {max_size=init_size; - size=0; - map=Array.create init_size dummy_node; - epsilons=[]; - axioms=Hashtbl.create init_size; - syms=Hashtbl.create init_size}; - terms=Intset.empty; - combine=Queue.create (); - marks=Queue.create (); - sigtable=ST.empty (); - diseq=[]; - quant=[]; - pa_classes=Intset.empty; - q_history=Hashtbl.create init_size; - rew_depth=depth; - by_type=Hashtbl.create init_size; - changed=false; - gls=gls} - -let forest state = state.uf - -let compress_path uf i j = uf.map.(j).cpath<-i - -let rec find_aux uf visited i= - let j = uf.map.(i).cpath in - if j<0 then let _ = List.iter (compress_path uf i) visited in i else - find_aux uf (i::visited) j - -let find uf i= find_aux uf [] i - -let get_representative uf i= - match uf.map.(i).clas with - Rep r -> r - | _ -> anomaly "get_representative: not a representative" - -let find_pac uf i pac = - PacMap.find pac (get_representative uf i).constructors - -let get_constructor_info uf i= - match uf.map.(i).term with - Constructor cinfo->cinfo - | _ -> anomaly "get_constructor: not a constructor" - -let size uf i= - (get_representative uf i).weight - -let axioms uf = uf.axioms - -let epsilons uf = uf.epsilons - -let add_lfather uf i t= - let r=get_representative uf i in - r.weight<-r.weight+1; - r.lfathers<-Intset.add t r.lfathers; - r.fathers <-Intset.add t r.fathers - -let add_rfather uf i t= - let r=get_representative uf i in - r.weight<-r.weight+1; - r.fathers <-Intset.add t r.fathers - -exception Discriminable of int * pa_constructor * int * pa_constructor - -let append_pac t p = - {p with arity=pred p.arity;args=t::p.args} - -let tail_pac p= - {p with arity=succ p.arity;args=List.tl p.args} - -let fsucc paf = - {paf with fnargs=succ paf.fnargs} - -let add_pac rep pac t = - if not (PacMap.mem pac rep.constructors) then - rep.constructors<-PacMap.add pac t rep.constructors - -let add_paf rep paf t = - let already = - try PafMap.find paf rep.functions with Not_found -> Intset.empty in - rep.functions<- PafMap.add paf (Intset.add t already) rep.functions - -let term uf i=uf.map.(i).term - -let subterms uf i= - match uf.map.(i).vertex with - Node(j,k) -> (j,k) - | _ -> anomaly "subterms: not a node" - -let signature uf i= - let j,k=subterms uf i in (find uf j,find uf k) - -let next uf= - let size=uf.size in - let nsize= succ size in - if nsize=uf.max_size then - let newmax=uf.max_size * 3 / 2 + 1 in - let newmap=Array.create newmax dummy_node in - begin - uf.max_size<-newmax; - Array.blit uf.map 0 newmap 0 size; - uf.map<-newmap - end - else (); - uf.size<-nsize; - size - -let new_representative typ = - {weight=0; - lfathers=Intset.empty; - fathers=Intset.empty; - inductive_status=Unknown; - class_type=typ; - functions=PafMap.empty; - constructors=PacMap.empty} - -(* rebuild a constr from an applicative term *) - -let _A_ = Name (id_of_string "A") -let _B_ = Name (id_of_string "A") -let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) - -let cc_product s1 s2 = - mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), - mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) - -let rec constr_of_term = function - Symb s->s - | Product(s1,s2) -> cc_product s1 s2 - | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr - | Appli (s1,s2)-> - make_app [(constr_of_term s2)] s1 -and make_app l=function - Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> applistc (constr_of_term other) l - -(* rebuild a term from a pattern and a substitution *) - -let build_subst uf subst = - Array.map (fun i -> - try term uf i - with _ -> anomaly "incomplete matching") subst - -let rec inst_pattern subst = function - PVar i -> - subst.(pred i) - | PApp (t, args) -> - List.fold_right - (fun spat f -> Appli (f,inst_pattern subst spat)) - args t - -let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" - -let pr_term t = str "[" ++ - Termops.print_constr (constr_of_term t) ++ str "]" - -let rec add_term state t= - let uf=state.uf in - try Hashtbl.find uf.syms t with - Not_found -> - let b=next uf in - let typ = pf_type_of state.gls (constr_of_term t) in - let new_node= - match t with - Symb _ | Product (_,_) -> - let paf = - {fsym=b; - fnargs=0} in - Queue.add (b,Fmark paf) state.marks; - {clas= Rep (new_representative typ); - cpath= -1; - vertex= Leaf; - term= t} - | Eps id -> - {clas= Rep (new_representative typ); - cpath= -1; - vertex= Leaf; - term= t} - | Appli (t1,t2) -> - let i1=add_term state t1 and i2=add_term state t2 in - add_lfather uf (find uf i1) b; - add_rfather uf (find uf i2) b; - state.terms<-Intset.add b state.terms; - {clas= Rep (new_representative typ); - cpath= -1; - vertex= Node(i1,i2); - term= t} - | Constructor cinfo -> - let paf = - {fsym=b; - fnargs=0} in - Queue.add (b,Fmark paf) state.marks; - let pac = - {cnode= b; - arity= cinfo.ci_arity; - args=[]} in - Queue.add (b,Cmark pac) state.marks; - {clas=Rep (new_representative typ); - cpath= -1; - vertex=Leaf; - term=t} - in - uf.map.(b)<-new_node; - Hashtbl.add uf.syms t b; - Hashtbl.replace state.by_type typ - (Intset.add b - (try Hashtbl.find state.by_type typ with - Not_found -> Intset.empty)); - b - -let add_equality state c s t= - let i = add_term state s in - let j = add_term state t in - Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; - Hashtbl.add state.uf.axioms c (s,t) - -let add_disequality state from s t = - let i = add_term state s in - let j = add_term state t in - state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq - -let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = - state.quant<- - {qe_hyp_id= id; - qe_pol= pol; - qe_nvars=nvars; - qe_lhs= patt1; - qe_lhs_valid=valid1; - qe_rhs= patt2; - qe_rhs_valid=valid2}::state.quant - -let is_redundant state id args = - try - let norm_args = Array.map (find state.uf) args in - let prev_args = Hashtbl.find_all state.q_history id in - List.exists - (fun old_args -> - Util.array_for_all2 (fun i j -> i = find state.uf j) - norm_args old_args) - prev_args - with Not_found -> false - -let add_inst state (inst,int_subst) = - check_for_interrupt (); - if state.rew_depth > 0 then - if is_redundant state inst.qe_hyp_id int_subst then - debug msgnl (str "discarding redundant (dis)equality") - else - begin - Hashtbl.add state.q_history inst.qe_hyp_id int_subst; - let subst = build_subst (forest state) int_subst in - let prfhead= mkVar inst.qe_hyp_id in - let args = Array.map constr_of_term subst in - let _ = array_rev args in (* highest deBruijn index first *) - let prf= mkApp(prfhead,args) in - let s = inst_pattern subst inst.qe_lhs - and t = inst_pattern subst inst.qe_rhs in - state.changed<-true; - state.rew_depth<-pred state.rew_depth; - if inst.qe_pol then - begin - debug (fun () -> - msgnl - (str "Adding new equality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ - pr_term s ++ str " == " ++ pr_term t ++ str "]")) (); - add_equality state prf s t - end - else - begin - debug (fun () -> - msgnl - (str "Adding new disequality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ - pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); - add_disequality state (Hyp prf) s t - end - end - -let link uf i j eq = (* links i -> j *) - let node=uf.map.(i) in - node.clas<-Eqto (j,eq); - node.cpath<-j - -let rec down_path uf i l= - match uf.map.(i).clas with - Eqto(j,t)->down_path uf j (((i,j),t)::l) - | Rep _ ->l - -let rec min_path=function - ([],l2)->([],l2) - | (l1,[])->(l1,[]) - | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) - | cpl -> cpl - -let join_path uf i j= - assert (find uf i=find uf j); - min_path (down_path uf i [],down_path uf j []) - -let union state i1 i2 eq= - debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ - str " and " ++ pr_idx_term state i2 ++ str ".")) (); - let r1= get_representative state.uf i1 - and r2= get_representative state.uf i2 in - link state.uf i1 i2 eq; - Hashtbl.replace state.by_type r1.class_type - (Intset.remove i1 - (try Hashtbl.find state.by_type r1.class_type with - Not_found -> Intset.empty)); - let f= Intset.union r1.fathers r2.fathers in - r2.weight<-Intset.cardinal f; - r2.fathers<-f; - r2.lfathers<-Intset.union r1.lfathers r2.lfathers; - ST.delete_set state.sigtable r1.fathers; - state.terms<-Intset.union state.terms r1.fathers; - PacMap.iter - (fun pac b -> Queue.add (b,Cmark pac) state.marks) - r1.constructors; - PafMap.iter - (fun paf -> Intset.iter - (fun b -> Queue.add (b,Fmark paf) state.marks)) - r1.functions; - match r1.inductive_status,r2.inductive_status with - Unknown,_ -> () - | Partial pac,Unknown -> - r2.inductive_status<-Partial pac; - state.pa_classes<-Intset.remove i1 state.pa_classes; - state.pa_classes<-Intset.add i2 state.pa_classes - | Partial _ ,(Partial _ |Partial_applied) -> - state.pa_classes<-Intset.remove i1 state.pa_classes - | Partial_applied,Unknown -> - r2.inductive_status<-Partial_applied - | Partial_applied,Partial _ -> - state.pa_classes<-Intset.remove i2 state.pa_classes; - r2.inductive_status<-Partial_applied - | Total cpl,Unknown -> r2.inductive_status<-Total cpl; - | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks - | _,_ -> () - -let merge eq state = (* merge and no-merge *) - debug (fun () -> msgnl - (str "Merging " ++ pr_idx_term state eq.lhs ++ - str " and " ++ pr_idx_term state eq.rhs ++ str ".")) (); - let uf=state.uf in - let i=find uf eq.lhs - and j=find uf eq.rhs in - if i<>j then - if (size uf i)<(size uf j) then - union state i j eq - else - union state j i (swap eq) - -let update t state = (* update 1 and 2 *) - debug (fun () -> msgnl - (str "Updating term " ++ pr_idx_term state t ++ str ".")) (); - let (i,j) as sign = signature state.uf t in - let (u,v) = subterms state.uf t in - let rep = get_representative state.uf i in - begin - match rep.inductive_status with - Partial _ -> - rep.inductive_status <- Partial_applied; - state.pa_classes <- Intset.remove i state.pa_classes - | _ -> () - end; - PacMap.iter - (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) - rep.constructors; - PafMap.iter - (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) - rep.functions; - try - let s = ST.query sign state.sigtable in - Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine - with - Not_found -> ST.enter t sign state.sigtable - -let process_function_mark t rep paf state = - add_paf rep paf t; - state.terms<-Intset.union rep.lfathers state.terms - -let process_constructor_mark t i rep pac state = - match rep.inductive_status with - Total (s,opac) -> - if pac.cnode <> opac.cnode then (* Conflict *) - raise (Discriminable (s,opac,t,pac)) - else (* Match *) - let cinfo = get_constructor_info state.uf pac.cnode in - let rec f n oargs args= - if n > 0 then - match (oargs,args) with - s1::q1,s2::q2-> - Queue.add - {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} - state.combine; - f (n-1) q1 q2 - | _-> anomaly - "add_pacs : weird error in injection subterms merge" - in f cinfo.ci_nhyps opac.args pac.args - | Partial_applied | Partial _ -> - add_pac rep pac t; - state.terms<-Intset.union rep.lfathers state.terms - | Unknown -> - if pac.arity = 0 then - rep.inductive_status <- Total (t,pac) - else - begin - add_pac rep pac t; - state.terms<-Intset.union rep.lfathers state.terms; - rep.inductive_status <- Partial pac; - state.pa_classes<- Intset.add i state.pa_classes - end - -let process_mark t m state = - debug (fun () -> msgnl - (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) (); - let i=find state.uf t in - let rep=get_representative state.uf i in - match m with - Fmark paf -> process_function_mark t rep paf state - | Cmark pac -> process_constructor_mark t i rep pac state - -type explanation = - Discrimination of (int*pa_constructor*int*pa_constructor) - | Contradiction of disequality - | Incomplete - -let check_disequalities state = - let uf=state.uf in - let rec check_aux = function - dis::q -> - debug (fun () -> msg - (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ - pr_idx_term state dis.rhs ++ str " ... ")) (); - if find uf dis.lhs=find uf dis.rhs then - begin debug msgnl (str "Yes");Some dis end - else - begin debug msgnl (str "No");check_aux q end - | [] -> None - in - check_aux state.diseq - -let one_step state = - try - let eq = Queue.take state.combine in - merge eq state; - true - with Queue.Empty -> - try - let (t,m) = Queue.take state.marks in - process_mark t m state; - true - with Queue.Empty -> - try - let t = Intset.choose state.terms in - state.terms<-Intset.remove t state.terms; - update t state; - true - with Not_found -> false - -let __eps__ = id_of_string "_eps_" - -let new_state_var typ state = - let id = pf_get_new_id __eps__ state.gls in - state.gls<- - {state.gls with it = - {state.gls.it with evar_hyps = - Environ.push_named_context_val (id,None,typ) - state.gls.it.evar_hyps}}; - id - -let complete_one_class state i= - match (get_representative state.uf i).inductive_status with - Partial pac -> - let rec app t typ n = - if n<=0 then t else - let _,etyp,rest= destProd typ in - let id = new_state_var etyp state in - app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = pf_type_of state.gls - (constr_of_term (term state.uf pac.cnode)) in - let _args = - List.map (fun i -> constr_of_term (term state.uf i)) - pac.args in - let typ = prod_applist _c (List.rev _args) in - let ct = app (term state.uf i) typ pac.arity in - state.uf.epsilons <- pac :: state.uf.epsilons; - ignore (add_term state ct) - | _ -> anomaly "wrong incomplete class" - -let complete state = - Intset.iter (complete_one_class state) state.pa_classes - -type matching_problem = -{mp_subst : int array; - mp_inst : quant_eq; - mp_stack : (ccpattern*int) list } - -let make_fun_table state = - let uf= state.uf in - let funtab=ref PafMap.empty in - Array.iteri - (fun i inode -> if i < uf.size then - match inode.clas with - Rep rep -> - PafMap.iter - (fun paf _ -> - let elem = - try PafMap.find paf !funtab - with Not_found -> Intset.empty in - funtab:= PafMap.add paf (Intset.add i elem) !funtab) - rep.functions - | _ -> ()) state.uf.map; - !funtab - - -let rec do_match state res pb_stack = - let mp=Stack.pop pb_stack in - match mp.mp_stack with - [] -> - res:= (mp.mp_inst,mp.mp_subst) :: !res - | (patt,cl)::remains -> - let uf=state.uf in - match patt with - PVar i -> - if mp.mp_subst.(pred i)<0 then - begin - mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) - Stack.push {mp with mp_stack=remains} pb_stack - end - else - if mp.mp_subst.(pred i) = cl then - Stack.push {mp with mp_stack=remains} pb_stack - else (* mismatch for non-linear variable in pattern *) () - | PApp (f,[]) -> - begin - try let j=Hashtbl.find uf.syms f in - if find uf j =cl then - Stack.push {mp with mp_stack=remains} pb_stack - with Not_found -> () - end - | PApp(f, ((last_arg::rem_args) as args)) -> - try - let j=Hashtbl.find uf.syms f in - let paf={fsym=j;fnargs=List.length args} in - let rep=get_representative uf cl in - let good_terms = PafMap.find paf rep.functions in - let aux i = - let (s,t) = signature state.uf i in - Stack.push - {mp with - mp_subst=Array.copy mp.mp_subst; - mp_stack= - (PApp(f,rem_args),s) :: - (last_arg,t) :: remains} pb_stack in - Intset.iter aux good_terms - with Not_found -> () - -let paf_of_patt syms = function - PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" - | PApp (f,args) -> - {fsym=Hashtbl.find syms f; - fnargs=List.length args} - -let init_pb_stack state = - let syms= state.uf.syms in - let pb_stack = Stack.create () in - let funtab = make_fun_table state in - let aux inst = - begin - let good_classes = - match inst.qe_lhs_valid with - Creates_variables -> Intset.empty - | Normal -> - begin - try - let paf= paf_of_patt syms inst.qe_lhs in - PafMap.find paf funtab - with Not_found -> Intset.empty - end - | Trivial typ -> - begin - try - Hashtbl.find state.by_type typ - with Not_found -> Intset.empty - end in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes - end; - begin - let good_classes = - match inst.qe_rhs_valid with - Creates_variables -> Intset.empty - | Normal -> - begin - try - let paf= paf_of_patt syms inst.qe_rhs in - PafMap.find paf funtab - with Not_found -> Intset.empty - end - | Trivial typ -> - begin - try - Hashtbl.find state.by_type typ - with Not_found -> Intset.empty - end in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes - end in - List.iter aux state.quant; - pb_stack - -let find_instances state = - let pb_stack= init_pb_stack state in - let res =ref [] in - let _ = - debug msgnl (str "Running E-matching algorithm ... "); - try - while true do - check_for_interrupt (); - do_match state res pb_stack - done; - anomaly "get out of here !" - with Stack.Empty -> () in - !res - -let rec execute first_run state = - debug msgnl (str "Executing ... "); - try - while - check_for_interrupt (); - one_step state do () - done; - match check_disequalities state with - None -> - if not(Intset.is_empty state.pa_classes) then - begin - debug msgnl (str "First run was incomplete, completing ... "); - complete state; - execute false state - end - else - if state.rew_depth>0 then - let l=find_instances state in - List.iter (add_inst state) l; - if state.changed then - begin - state.changed <- false; - execute true state - end - else - begin - debug msgnl (str "Out of instances ... "); - None - end - else - begin - debug msgnl (str "Out of depth ... "); - None - end - | Some dis -> Some - begin - if first_run then Contradiction dis - else Incomplete - end - with Discriminable(s,spac,t,tpac) -> Some - begin - if first_run then Discrimination (s,spac,t,tpac) - else Incomplete - end - - diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli deleted file mode 100644 index cdc0065e..00000000 --- a/contrib/cc/ccalgo.mli +++ /dev/null @@ -1,222 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *) - -open Util -open Term -open Names - -type cinfo = - {ci_constr: constructor; (* inductive type *) - ci_arity: int; (* # args *) - ci_nhyps: int} (* # projectable args *) - -type term = - Symb of constr - | Product of sorts_family * sorts_family - | Eps of identifier - | Appli of term*term - | Constructor of cinfo (* constructor arity + nhyps *) - -type patt_kind = - Normal - | Trivial of types - | Creates_variables - -type ccpattern = - PApp of term * ccpattern list - | PVar of int - -type pa_constructor = - { cnode : int; - arity : int; - args : int list} - -module PacMap : Map.S with type key = pa_constructor - -type forest - -type state - -type rule= - Congruence - | Axiom of constr * bool - | Injection of int * pa_constructor * int * pa_constructor * int - -type from= - Goal - | Hyp of constr - | HeqG of constr - | HeqnH of constr*constr - -type 'a eq = {lhs:int;rhs:int;rule:'a} - -type equality = rule eq - -type disequality = from eq - -type explanation = - Discrimination of (int*pa_constructor*int*pa_constructor) - | Contradiction of disequality - | Incomplete - -val constr_of_term : term -> constr - -val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit - -val forest : state -> forest - -val axioms : forest -> (constr, term * term) Hashtbl.t - -val epsilons : forest -> pa_constructor list - -val empty : int -> Proof_type.goal Tacmach.sigma -> state - -val add_term : state -> term -> int - -val add_equality : state -> constr -> term -> term -> unit - -val add_disequality : state -> from -> term -> term -> unit - -val add_quant : state -> identifier -> bool -> - int * patt_kind * ccpattern * patt_kind * ccpattern -> unit - -val tail_pac : pa_constructor -> pa_constructor - -val find : forest -> int -> int - -val find_pac : forest -> int -> pa_constructor -> int - -val term : forest -> int -> term - -val get_constructor_info : forest -> int -> cinfo - -val subterms : forest -> int -> int * int - -val join_path : forest -> int -> int -> - ((int * int) * equality) list * ((int * int) * equality) list - -type quant_eq= - {qe_hyp_id: identifier; - qe_pol: bool; - qe_nvars:int; - qe_lhs: ccpattern; - qe_lhs_valid:patt_kind; - qe_rhs: ccpattern; - qe_rhs_valid:patt_kind} - - -type pa_fun= - {fsym:int; - fnargs:int} - -type matching_problem - -module PafMap: Map.S with type key = pa_fun - -val make_fun_table : state -> Intset.t PafMap.t - -val do_match : state -> - (quant_eq * int array) list ref -> matching_problem Stack.t -> unit - -val init_pb_stack : state -> matching_problem Stack.t - -val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun - -val find_instances : state -> (quant_eq * int array) list - -val execute : bool -> state -> explanation option - - - - - - - - - - - - - -(*type pa_constructor - - -module PacMap:Map.S with type key=pa_constructor - -type term = - Symb of Term.constr - | Eps - | Appli of term * term - | Constructor of Names.constructor*int*int - -type rule = - Congruence - | Axiom of Names.identifier - | Injection of int*int*int*int - -type equality = - {lhs : int; - rhs : int; - rule : rule} - -module ST : -sig - type t - val empty : unit -> t - val enter : int -> int * int -> t -> unit - val query : int * int -> t -> int - val delete : int -> t -> unit - val delete_list : int list -> t -> unit -end - -module UF : -sig - type t - exception Discriminable of int * int * int * int * t - val empty : unit -> t - val find : t -> int -> int - val size : t -> int -> int - val get_constructor : t -> int -> Names.constructor - val pac_arity : t -> int -> int * int -> int - val mem_node_pac : t -> int -> int * int -> int - val add_pacs : t -> int -> pa_constructor PacMap.t -> - int list * equality list - val term : t -> int -> term - val subterms : t -> int -> int * int - val add : t -> term -> int - val union : t -> int -> int -> equality -> int list * equality list - val join_path : t -> int -> int -> - ((int*int)*equality) list* - ((int*int)*equality) list -end - - -val combine_rec : UF.t -> int list -> equality list -val process_rec : UF.t -> equality list -> int list - -val cc : UF.t -> unit - -val make_uf : - (Names.identifier * (term * term)) list -> UF.t - -val add_one_diseq : UF.t -> (term * term) -> int * int - -val add_disaxioms : - UF.t -> (Names.identifier * (term * term)) list -> - (Names.identifier * (int * int)) list - -val check_equal : UF.t -> int * int -> bool - -val find_contradiction : UF.t -> - (Names.identifier * (int * int)) list -> - (Names.identifier * (int * int)) -*) - - diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml deleted file mode 100644 index a459b18f..00000000 --- a/contrib/cc/ccproof.ml +++ /dev/null @@ -1,153 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ccproof.ml 9857 2007-05-24 14:21:08Z corbinea $ *) - -(* This file uses the (non-compressed) union-find structure to generate *) -(* proof-trees that will be transformed into proof-terms in cctac.ml4 *) - -open Util -open Names -open Term -open Ccalgo - -type rule= - Ax of constr - | SymAx of constr - | Refl of term - | Trans of proof*proof - | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = - {p_lhs:term;p_rhs:term;p_rule:rule} - -let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t} - -let pcongr p1 p2 = - match p1.p_rule,p2.p_rule with - Refl t1, Refl t2 -> prefl (Appli (t1,t2)) - | _, _ -> - {p_lhs=Appli (p1.p_lhs,p2.p_lhs); - p_rhs=Appli (p1.p_rhs,p2.p_rhs); - p_rule=Congr (p1,p2)} - -let rec ptrans p1 p3= - match p1.p_rule,p3.p_rule with - Refl _, _ ->p3 - | _, Refl _ ->p1 - | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) - | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) - | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> - ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 - | _, _ -> - if p1.p_rhs = p3.p_lhs then - {p_lhs=p1.p_lhs; - p_rhs=p3.p_rhs; - p_rule=Trans (p1,p3)} - else anomaly "invalid cc transitivity" - -let rec psym p = - match p.p_rule with - Refl _ -> p - | SymAx s -> - {p_lhs=p.p_rhs; - p_rhs=p.p_lhs; - p_rule=Ax s} - | Ax s-> - {p_lhs=p.p_rhs; - p_rhs=p.p_lhs; - p_rule=SymAx s} - | Inject (p0,c,n,a)-> - {p_lhs=p.p_rhs; - p_rhs=p.p_lhs; - p_rule=Inject (psym p0,c,n,a)} - | Trans (p1,p2)-> ptrans (psym p2) (psym p1) - | Congr (p1,p2)-> pcongr (psym p1) (psym p2) - -let pax axioms s = - let l,r = Hashtbl.find axioms s in - {p_lhs=l; - p_rhs=r; - p_rule=Ax s} - -let psymax axioms s = - let l,r = Hashtbl.find axioms s in - {p_lhs=r; - p_rhs=l; - p_rule=SymAx s} - -let rec nth_arg t n= - match t with - Appli (t1,t2)-> - if n>0 then - nth_arg t1 (n-1) - else t2 - | _ -> anomaly "nth_arg: not enough args" - -let pinject p c n a = - {p_lhs=nth_arg p.p_lhs (n-a); - p_rhs=nth_arg p.p_rhs (n-a); - p_rule=Inject(p,c,n,a)} - -let build_proof uf= - - let axioms = axioms uf in - - let rec equal_proof i j= - if i=j then prefl (term uf i) else - let (li,lj)=join_path uf i j in - ptrans (path_proof i li) (psym (path_proof j lj)) - - and edge_proof ((i,j),eq)= - let pi=equal_proof i eq.lhs in - let pj=psym (equal_proof j eq.rhs) in - let pij= - match eq.rule with - Axiom (s,reversed)-> - if reversed then psymax axioms s - else pax axioms s - | Congruence ->congr_proof eq.lhs eq.rhs - | Injection (ti,ipac,tj,jpac,k) -> - let p=ind_proof ti ipac tj jpac in - let cinfo= get_constructor_info uf ipac.cnode in - pinject p cinfo.ci_constr cinfo.ci_nhyps k - in ptrans (ptrans pi pij) pj - - and constr_proof i t ipac= - if ipac.args=[] then - equal_proof i t - else - let npac=tail_pac ipac in - let (j,arg)=subterms uf t in - let targ=term uf arg in - let rj=find uf j in - let u=find_pac uf rj npac in - let p=constr_proof j u npac in - ptrans (equal_proof i t) (pcongr p (prefl targ)) - - and path_proof i=function - [] -> prefl (term uf i) - | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) - - and congr_proof i j= - let (i1,i2) = subterms uf i - and (j1,j2) = subterms uf j in - pcongr (equal_proof i1 j1) (equal_proof i2 j2) - - and ind_proof i ipac j jpac= - let p=equal_proof i j - and p1=constr_proof i i ipac - and p2=constr_proof j j jpac in - ptrans (psym p1) (ptrans p p2) - in - function - `Prove (i,j) -> equal_proof i j - | `Discr (i,ci,j,cj)-> ind_proof i ci j cj - - - diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli deleted file mode 100644 index 0eb97efe..00000000 --- a/contrib/cc/ccproof.mli +++ /dev/null @@ -1,31 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *) - -open Ccalgo -open Names -open Term - -type rule= - Ax of constr - | SymAx of constr - | Refl of term - | Trans of proof*proof - | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = - private {p_lhs:term;p_rhs:term;p_rule:rule} - -val build_proof : - forest -> - [ `Discr of int * pa_constructor * int * pa_constructor - | `Prove of int * int ] -> proof - - - diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml deleted file mode 100644 index 00cbbeee..00000000 --- a/contrib/cc/cctac.ml +++ /dev/null @@ -1,465 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: cctac.ml 11671 2008-12-12 12:43:03Z herbelin $ *) - -(* This file is the interface between the c-c algorithm and Coq *) - -open Evd -open Proof_type -open Names -open Libnames -open Nameops -open Inductiveops -open Declarations -open Term -open Termops -open Tacmach -open Tactics -open Tacticals -open Typing -open Ccalgo -open Tacinterp -open Ccproof -open Pp -open Util -open Format - -let constant dir s = lazy (Coqlib.gen_constant "CC" dir s) - -let _f_equal = constant ["Init";"Logic"] "f_equal" - -let _eq_rect = constant ["Init";"Logic"] "eq_rect" - -let _refl_equal = constant ["Init";"Logic"] "refl_equal" - -let _sym_eq = constant ["Init";"Logic"] "sym_eq" - -let _trans_eq = constant ["Init";"Logic"] "trans_eq" - -let _eq = constant ["Init";"Logic"] "eq" - -let _False = constant ["Init";"Logic"] "False" - -let whd env= - let infos=Closure.create_clos_infos Closure.betaiotazeta env in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let whd_delta env= - let infos=Closure.create_clos_infos Closure.betadeltaiota env in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -(* decompose member of equality in an applicative format *) - -let sf_of env sigma c = family_of_sort (destSort (whd_delta env (type_of env sigma c))) - -let rec decompose_term env sigma t= - match kind_of_term (whd env t) with - App (f,args)-> - let tf=decompose_term env sigma f in - let targs=Array.map (decompose_term env sigma) args in - Array.fold_left (fun s t->Appli (s,t)) tf targs - | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> - let b = pop _b in - let sort_b = sf_of env sigma b in - let sort_a = sf_of env sigma a in - Appli(Appli(Product (sort_a,sort_b) , - decompose_term env sigma a), - decompose_term env sigma b) - | Construct c-> - let (oib,_)=Global.lookup_inductive (fst c) in - let nargs=mis_constructor_nargs_env env c in - Constructor {ci_constr=c; - ci_arity=nargs; - ci_nhyps=nargs-oib.mind_nparams} - | _ ->if closed0 t then (Symb t) else raise Not_found - -(* decompose equality in members and type *) - -let atom_of_constr env sigma term = - let wh = (whd_delta env term) in - let kot = kind_of_term wh in - match kot with - App (f,args)-> - if eq_constr f (Lazy.force _eq) && (Array.length args)=3 - then `Eq (args.(0), - decompose_term env sigma args.(1), - decompose_term env sigma args.(2)) - else `Other (decompose_term env sigma term) - | _ -> `Other (decompose_term env sigma term) - -let rec pattern_of_constr env sigma c = - match kind_of_term (whd env c) with - App (f,args)-> - let pf = decompose_term env sigma f in - let pargs,lrels = List.split - (array_map_to_list (pattern_of_constr env sigma) args) in - PApp (pf,List.rev pargs), - List.fold_left Intset.union Intset.empty lrels - | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> - let b =pop _b in - let pa,sa = pattern_of_constr env sigma a in - let pb,sb = pattern_of_constr env sigma (pop b) in - let sort_b = sf_of env sigma b in - let sort_a = sf_of env sigma a in - PApp(Product (sort_a,sort_b), - [pa;pb]),(Intset.union sa sb) - | Rel i -> PVar i,Intset.singleton i - | _ -> - let pf = decompose_term env sigma c in - PApp (pf,[]),Intset.empty - -let non_trivial = function - PVar _ -> false - | _ -> true - -let patterns_of_constr env sigma nrels term= - let f,args= - try destApp (whd_delta env term) with _ -> raise Not_found in - if eq_constr f (Lazy.force _eq) && (Array.length args)=3 - then - let patt1,rels1 = pattern_of_constr env sigma args.(1) - and patt2,rels2 = pattern_of_constr env sigma args.(2) in - let valid1 = - if Intset.cardinal rels1 <> nrels then Creates_variables - else if non_trivial patt1 then Normal - else Trivial args.(0) - and valid2 = - if Intset.cardinal rels2 <> nrels then Creates_variables - else if non_trivial patt2 then Normal - else Trivial args.(0) in - if valid1 <> Creates_variables - || valid2 <> Creates_variables then - nrels,valid1,patt1,valid2,patt2 - else raise Not_found - else raise Not_found - -let rec quantified_atom_of_constr env sigma nrels term = - match kind_of_term (whd_delta env term) with - Prod (_,atom,ff) -> - if eq_constr ff (Lazy.force _False) then - let patts=patterns_of_constr env sigma nrels atom in - `Nrule patts - else - quantified_atom_of_constr env sigma (succ nrels) ff - | _ -> - let patts=patterns_of_constr env sigma nrels term in - `Rule patts - -let litteral_of_constr env sigma term= - match kind_of_term (whd_delta env term) with - | Prod (_,atom,ff) -> - if eq_constr ff (Lazy.force _False) then - match (atom_of_constr env sigma atom) with - `Eq(t,a,b) -> `Neq(t,a,b) - | `Other(p) -> `Nother(p) - else - begin - try - quantified_atom_of_constr env sigma 1 ff - with Not_found -> - `Other (decompose_term env sigma term) - end - | _ -> - atom_of_constr env sigma term - - -(* store all equalities from the context *) - -let rec make_prb gls depth additionnal_terms = - let env=pf_env gls in - let sigma=sig_sig gls in - let state = empty depth gls in - let pos_hyps = ref [] in - let neg_hyps =ref [] in - List.iter - (fun c -> - let t = decompose_term env sigma c in - ignore (add_term state t)) additionnal_terms; - List.iter - (fun (id,_,e) -> - begin - let cid=mkVar id in - match litteral_of_constr env sigma e with - `Eq (t,a,b) -> add_equality state cid a b - | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b - | `Other ph -> - List.iter - (fun (cidn,nh) -> - add_disequality state (HeqnH (cid,cidn)) ph nh) - !neg_hyps; - pos_hyps:=(cid,ph):: !pos_hyps - | `Nother nh -> - List.iter - (fun (cidp,ph) -> - add_disequality state (HeqnH (cidp,cid)) ph nh) - !pos_hyps; - neg_hyps:=(cid,nh):: !neg_hyps - | `Rule patts -> add_quant state id true patts - | `Nrule patts -> add_quant state id false patts - end) (Environ.named_context_of_val gls.it.evar_hyps); - begin - match atom_of_constr env sigma gls.it.evar_concl with - `Eq (t,a,b) -> add_disequality state Goal a b - | `Other g -> - List.iter - (fun (idp,ph) -> - add_disequality state (HeqG idp) ph g) !pos_hyps - end; - state - -(* indhyps builds the array of arrays of constructor hyps for (ind largs) *) - -let build_projection intype outtype (cstr:constructor) special default gls= - let env=pf_env gls in - let (h,argv) = - try destApp intype with - Invalid_argument _ -> (intype,[||]) in - let ind=destInd h in - let types=Inductiveops.arities_of_constructors env ind in - let lp=Array.length types in - let ci=pred (snd cstr) in - let branch i= - let ti=Term.prod_appvect types.(i) argv in - let rc=fst (Sign.decompose_prod_assum ti) in - let head= - if i=ci then special else default in - Sign.it_mkLambda_or_LetIn head rc in - let branches=Array.init lp branch in - let casee=mkRel 1 in - let pred=mkLambda(Anonymous,intype,outtype) in - let case_info=make_case_info (pf_env gls) ind RegularStyle in - let body= mkCase(case_info, pred, casee, branches) in - let id=pf_get_new_id (id_of_string "t") gls in - mkLambda(Name id,intype,body) - -(* generate an adhoc tactic following the proof tree *) - -let _M =mkMeta - -let rec proof_tac p gls = - match p.p_rule with - Ax c -> exact_check c gls - | SymAx c -> - let l=constr_of_term p.p_lhs and - r=constr_of_term p.p_rhs in - let typ = refresh_universes (pf_type_of gls l) in - exact_check - (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls - | Refl t -> - let lr = constr_of_term t in - let typ = refresh_universes (pf_type_of gls lr) in - exact_check - (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls - | Trans (p1,p2)-> - let t1 = constr_of_term p1.p_lhs and - t2 = constr_of_term p1.p_rhs and - t3 = constr_of_term p2.p_rhs in - let typ = refresh_universes (pf_type_of gls t2) in - let prf = - mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in - tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls - | Congr (p1,p2)-> - let tf1=constr_of_term p1.p_lhs - and tx1=constr_of_term p2.p_lhs - and tf2=constr_of_term p1.p_rhs - and tx2=constr_of_term p2.p_rhs in - let typf = refresh_universes (pf_type_of gls tf1) in - let typx = refresh_universes (pf_type_of gls tx1) in - let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in - let id = pf_get_new_id (id_of_string "f") gls in - let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in - let lemma1 = - mkApp(Lazy.force _f_equal, - [|typf;typfx;appx1;tf1;tf2;_M 1|]) in - let lemma2= - mkApp(Lazy.force _f_equal, - [|typx;typfx;tf2;tx1;tx2;_M 1|]) in - let prf = - mkApp(Lazy.force _trans_eq, - [|typfx; - mkApp(tf1,[|tx1|]); - mkApp(tf2,[|tx1|]); - mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in - tclTHENS (refine prf) - [tclTHEN (refine lemma1) (proof_tac p1); - tclFIRST - [tclTHEN (refine lemma2) (proof_tac p2); - reflexivity; - fun gls -> - errorlabstrm "Congruence" - (Pp.str - "I don't know how to handle dependent equality")]] gls - | Inject (prf,cstr,nargs,argind) -> - let ti=constr_of_term prf.p_lhs in - let tj=constr_of_term prf.p_rhs in - let default=constr_of_term p.p_lhs in - let intype=refresh_universes (pf_type_of gls ti) in - let outtype=refresh_universes (pf_type_of gls default) in - let special=mkRel (1+nargs-argind) in - let proj=build_projection intype outtype cstr special default gls in - let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in - tclTHEN (refine injt) (proof_tac prf) gls - -let refute_tac c t1 t2 p gls = - let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype=refresh_universes (pf_type_of gls tt1) in - let neweq= - mkApp(Lazy.force _eq, - [|intype;tt1;tt2|]) in - let hid=pf_get_new_id (id_of_string "Heq") gls in - let false_t=mkApp (c,[|mkVar hid|]) in - tclTHENS (assert_tac (Name hid) neweq) - [proof_tac p; simplest_elim false_t] gls - -let convert_to_goal_tac c t1 t2 p gls = - let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let sort=refresh_universes (pf_type_of gls tt2) in - let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in - let e=pf_get_new_id (id_of_string "e") gls in - let x=pf_get_new_id (id_of_string "X") gls in - let identity=mkLambda (Name x,sort,mkRel 1) in - let endt=mkApp (Lazy.force _eq_rect, - [|sort;tt1;identity;c;tt2;mkVar e|]) in - tclTHENS (assert_tac (Name e) neweq) - [proof_tac p;exact_check endt] gls - -let convert_to_hyp_tac c1 t1 c2 t2 p gls = - let tt2=constr_of_term t2 in - let h=pf_get_new_id (id_of_string "H") gls in - let false_t=mkApp (c2,[|mkVar h|]) in - tclTHENS (assert_tac (Name h) tt2) - [convert_to_goal_tac c1 t1 t2 p; - simplest_elim false_t] gls - -let discriminate_tac cstr p gls = - let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in - let intype=refresh_universes (pf_type_of gls t1) in - let concl=pf_concl gls in - let outsort=mkType (new_univ ()) in - let xid=pf_get_new_id (id_of_string "X") gls in - let tid=pf_get_new_id (id_of_string "t") gls in - let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in - let trivial=pf_type_of gls identity in - let outtype=mkType (new_univ ()) in - let pred=mkLambda(Name xid,outtype,mkRel 1) in - let hid=pf_get_new_id (id_of_string "Heq") gls in - let proj=build_projection intype outtype cstr trivial concl gls in - let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;t1;t2;mkVar hid|]) in - let endt=mkApp (Lazy.force _eq_rect, - [|outtype;trivial;pred;identity;concl;injt|]) in - let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - tclTHENS (assert_tac (Name hid) neweq) - [proof_tac p;exact_check endt] gls - -(* wrap everything *) - -let build_term_to_complete uf meta pac = - let cinfo = get_constructor_info uf pac.cnode in - let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in - let dummy_args = List.rev (list_tabulate meta pac.arity) in - let all_args = List.rev_append real_args dummy_args in - applistc (mkConstruct cinfo.ci_constr) all_args - -let cc_tactic depth additionnal_terms gls= - Coqlib.check_required_library ["Coq";"Init";"Logic"]; - let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in - let state = make_prb gls depth additionnal_terms in - let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in - let sol = execute true state in - let _ = debug Pp.msgnl (Pp.str "Computation completed.") in - let uf=forest state in - match sol with - None -> tclFAIL 0 (str "congruence failed") gls - | Some reason -> - debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); - match reason with - Discrimination (i,ipac,j,jpac) -> - let p=build_proof uf (`Discr (i,ipac,j,jpac)) in - let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac cstr p gls - | Incomplete -> - let metacnt = ref 0 in - let newmeta _ = incr metacnt; _M !metacnt in - let terms_to_complete = - List.map - (build_term_to_complete uf newmeta) - (epsilons uf) in - Pp.msgnl - (Pp.str "Goal is solvable by congruence but \ - some arguments are missing."); - Pp.msgnl - (Pp.str " Try " ++ - hov 8 - begin - str "\"congruence with (" ++ - prlist_with_sep - (fun () -> str ")" ++ pr_spc () ++ str "(") - (print_constr_env (pf_env gls)) - terms_to_complete ++ - str ")\"," - end); - Pp.msgnl - (Pp.str " replacing metavariables by arbitrary terms."); - tclFAIL 0 (str "Incomplete") gls - | Contradiction dis -> - let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in - let ta=term uf dis.lhs and tb=term uf dis.rhs in - match dis.rule with - Goal -> proof_tac p gls - | Hyp id -> refute_tac id ta tb p gls - | HeqG id -> - convert_to_goal_tac id ta tb p gls - | HeqnH (ida,idb) -> - convert_to_hyp_tac ida ta idb tb p gls - - -let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") - -let congruence_tac depth l = - tclORELSE - (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) - cc_fail - -(* Beware: reflexivity = constructor 1 = apply refl_equal - might be slow now, let's rather do something equivalent - to a "simple apply refl_equal" *) - -let simple_reflexivity () = apply (Lazy.force _refl_equal) - -(* The [f_equal] tactic. - - It mimics the use of lemmas [f_equal], [f_equal2], etc. - This isn't particularly related with congruence, apart from - the fact that congruence is called internally. -*) - -let f_equal gl = - let cut_eq c1 c2 = - let ty = refresh_universes (pf_type_of gl c1) in - tclTHENTRY - (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) - (simple_reflexivity ()) - in - try match kind_of_term (pf_concl gl) with - | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> - begin match kind_of_term t, kind_of_term t' with - | App (f,v), App (f',v') when Array.length v = Array.length v' -> - let rec cuts i = - if i < 0 then tclTRY (congruence_tac 1000 []) - else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) - in cuts (Array.length v - 1) gl - | _ -> tclIDTAC gl - end - | _ -> tclIDTAC gl - with Type_errors.TypeError _ -> tclIDTAC gl diff --git a/contrib/cc/cctac.mli b/contrib/cc/cctac.mli deleted file mode 100644 index 57ad0558..00000000 --- a/contrib/cc/cctac.mli +++ /dev/null @@ -1,22 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *) - -open Term -open Proof_type - -val proof_tac: Ccproof.proof -> Proof_type.tactic - -val cc_tactic : int -> constr list -> tactic - -val cc_fail : tactic - -val congruence_tac : int -> constr list -> tactic - -val f_equal : tactic diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4 deleted file mode 100644 index 9877e6fc..00000000 --- a/contrib/cc/g_congruence.ml4 +++ /dev/null @@ -1,29 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *) - -open Cctac -open Tactics -open Tacticals - -(* Tactic registration *) - -TACTIC EXTEND cc - [ "congruence" ] -> [ congruence_tac 1000 [] ] - |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] - |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> - [ congruence_tac n l ] -END - -TACTIC EXTEND f_equal - [ "f_equal" ] -> [ f_equal ] -END diff --git a/contrib/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v deleted file mode 100644 index 30f5ac8f..00000000 --- a/contrib/correctness/ArrayPermut.v +++ /dev/null @@ -1,175 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ArrayPermut.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -(****************************************************************************) -(* Permutations of elements in arrays *) -(* Definition and properties *) -(****************************************************************************) - -Require Import ProgInt. -Require Import Arrays. -Require Export Exchange. - -Require Import Omega. - -Set Implicit Arguments. - -(* We define "permut" as the smallest equivalence relation which contains - * transpositions i.e. exchange of two elements. - *) - -Inductive permut (n:Z) (A:Set) : array n A -> array n A -> Prop := - | exchange_is_permut : - forall (t t':array n A) (i j:Z), exchange t t' i j -> permut t t' - | permut_refl : forall t:array n A, permut t t - | permut_sym : forall t t':array n A, permut t t' -> permut t' t - | permut_trans : - forall t t' t'':array n A, permut t t' -> permut t' t'' -> permut t t''. - -Hint Resolve exchange_is_permut permut_refl permut_sym permut_trans: v62 - datatypes. - -(* We also define the permutation on a segment of an array, "sub_permut", - * the other parts of the array being unchanged - * - * One again we define it as the smallest equivalence relation containing - * transpositions on the given segment. - *) - -Inductive sub_permut (n:Z) (A:Set) (g d:Z) : -array n A -> array n A -> Prop := - | exchange_is_sub_permut : - forall (t t':array n A) (i j:Z), - (g <= i <= d)%Z -> - (g <= j <= d)%Z -> exchange t t' i j -> sub_permut g d t t' - | sub_permut_refl : forall t:array n A, sub_permut g d t t - | sub_permut_sym : - forall t t':array n A, sub_permut g d t t' -> sub_permut g d t' t - | sub_permut_trans : - forall t t' t'':array n A, - sub_permut g d t t' -> sub_permut g d t' t'' -> sub_permut g d t t''. - -Hint Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym - sub_permut_trans: v62 datatypes. - -(* To express that some parts of arrays are equal we introduce the - * property "array_id" which says that a segment is the same on two - * arrays. - *) - -Definition array_id (n:Z) (A:Set) (t t':array n A) - (g d:Z) := forall i:Z, (g <= i <= d)%Z -> #t [i] = #t' [i]. - -(* array_id is an equivalence relation *) - -Lemma array_id_refl : - forall (n:Z) (A:Set) (t:array n A) (g d:Z), array_id t t g d. -Proof. -unfold array_id in |- *. -auto with datatypes. -Qed. - -Hint Resolve array_id_refl: v62 datatypes. - -Lemma array_id_sym : - forall (n:Z) (A:Set) (t t':array n A) (g d:Z), - array_id t t' g d -> array_id t' t g d. -Proof. -unfold array_id in |- *. intros. -symmetry in |- *; auto with datatypes. -Qed. - -Hint Resolve array_id_sym: v62 datatypes. - -Lemma array_id_trans : - forall (n:Z) (A:Set) (t t' t'':array n A) (g d:Z), - array_id t t' g d -> array_id t' t'' g d -> array_id t t'' g d. -Proof. -unfold array_id in |- *. intros. -apply trans_eq with (y := #t' [i]); auto with datatypes. -Qed. - -Hint Resolve array_id_trans: v62 datatypes. - -(* Outside the segment [g,d] the elements are equal *) - -Lemma sub_permut_id : - forall (n:Z) (A:Set) (t t':array n A) (g d:Z), - sub_permut g d t t' -> - array_id t t' 0 (g - 1) /\ array_id t t' (d + 1) (n - 1). -Proof. -intros n A t t' g d. simple induction 1; intros. -elim H2; intros. -unfold array_id in |- *; split; intros. -apply H7; omega. -apply H7; omega. -auto with datatypes. -decompose [and] H1; auto with datatypes. -decompose [and] H1; decompose [and] H3; eauto with datatypes. -Qed. - -Hint Resolve sub_permut_id. - -Lemma sub_permut_eq : - forall (n:Z) (A:Set) (t t':array n A) (g d:Z), - sub_permut g d t t' -> - forall i:Z, (0 <= i < g)%Z \/ (d < i < n)%Z -> #t [i] = #t' [i]. -Proof. -intros n A t t' g d Htt' i Hi. -elim (sub_permut_id Htt'). unfold array_id in |- *. -intros. -elim Hi; [ intro; apply H; omega | intro; apply H0; omega ]. -Qed. - -(* sub_permut is a particular case of permutation *) - -Lemma sub_permut_is_permut : - forall (n:Z) (A:Set) (t t':array n A) (g d:Z), - sub_permut g d t t' -> permut t t'. -Proof. -intros n A t t' g d. simple induction 1; intros; eauto with datatypes. -Qed. - -Hint Resolve sub_permut_is_permut. - -(* If we have a sub-permutation on an empty segment, then we have a - * sub-permutation on any segment. - *) - -Lemma sub_permut_void : - forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z), - (d < g)%Z -> sub_permut g d t t' -> sub_permut g' d' t t'. -Proof. -intros N A t t' g g' d d' Hdg. -simple induction 1; intros. -absurd (g <= d)%Z; omega. -auto with datatypes. -auto with datatypes. -eauto with datatypes. -Qed. - -(* A sub-permutation on a segment may be extended to any segment that - * contains the first one. - *) - -Lemma sub_permut_extension : - forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z), - (g' <= g)%Z -> (d <= d')%Z -> sub_permut g d t t' -> sub_permut g' d' t t'. -Proof. -intros N A t t' g g' d d' Hgg' Hdd'. -simple induction 1; intros. -apply exchange_is_sub_permut with (i := i) (j := j); - [ omega | omega | assumption ]. -auto with datatypes. -auto with datatypes. -eauto with datatypes. -Qed.
\ No newline at end of file diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v deleted file mode 100644 index 3a6aaaf8..00000000 --- a/contrib/correctness/Arrays.v +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Arrays.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -(**********************************************) -(* Functional arrays, for use in Correctness. *) -(**********************************************) - -(* This is an axiomatization of arrays. - * - * The type (array N T) is the type of arrays ranging from 0 to N-1 - * which elements are of type T. - * - * Arrays are created with new, accessed with access and modified with store. - * - * Operations of accessing and storing are not guarded, but axioms are. - * So these arrays can be viewed as arrays where accessing and storing - * out of the bounds has no effect. - *) - - -Require Export ProgInt. - -Set Implicit Arguments. - - -(* The type of arrays *) - -Parameter array : Z -> Set -> Set. - - -(* Functions to create, access and modify arrays *) - -Parameter new : forall (n:Z) (T:Set), T -> array n T. - -Parameter access : forall (n:Z) (T:Set), array n T -> Z -> T. - -Parameter store : forall (n:Z) (T:Set), array n T -> Z -> T -> array n T. - - -(* Axioms *) - -Axiom - new_def : - forall (n:Z) (T:Set) (v0:T) (i:Z), - (0 <= i < n)%Z -> access (new n v0) i = v0. - -Axiom - store_def_1 : - forall (n:Z) (T:Set) (t:array n T) (v:T) (i:Z), - (0 <= i < n)%Z -> access (store t i v) i = v. - -Axiom - store_def_2 : - forall (n:Z) (T:Set) (t:array n T) (v:T) (i j:Z), - (0 <= i < n)%Z -> - (0 <= j < n)%Z -> i <> j -> access (store t i v) j = access t j. - -Hint Resolve new_def store_def_1 store_def_2: datatypes v62. - -(* A tactic to simplify access in arrays *) - -Ltac array_access i j H := - elim (Z_eq_dec i j); - [ intro H; rewrite H; rewrite store_def_1 - | intro H; rewrite store_def_2; [ idtac | idtac | idtac | exact H ] ]. - -(* Symbolic notation for access *) - -Notation "# t [ c ]" := (access t c) (at level 0, t at level 0).
\ No newline at end of file diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v deleted file mode 100644 index a8a2858f..00000000 --- a/contrib/correctness/Arrays_stuff.v +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Arrays_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export Exchange. -Require Export ArrayPermut. -Require Export Sorted. - diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v deleted file mode 100644 index b7513d09..00000000 --- a/contrib/correctness/Correctness.v +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Correctness.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -(* Correctness is base on the tactic Refine (developped on purpose) *) - -Require Export Tuples. - -Require Export ProgInt. -Require Export ProgBool. -Require Export Zwf. - -Require Export Arrays. - -(* -Token "'". -*)
\ No newline at end of file diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v deleted file mode 100644 index 035a98f2..00000000 --- a/contrib/correctness/Exchange.v +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Exchange.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -(****************************************************************************) -(* Exchange of two elements in an array *) -(* Definition and properties *) -(****************************************************************************) - -Require Import ProgInt. -Require Import Arrays. - -Set Implicit Arguments. - -(* Definition *) - -Inductive exchange (n:Z) (A:Set) (t t':array n A) (i j:Z) : Prop := - exchange_c : - (0 <= i < n)%Z -> - (0 <= j < n)%Z -> - #t [i] = #t' [j] -> - #t [j] = #t' [i] -> - (forall k:Z, (0 <= k < n)%Z -> k <> i -> k <> j -> #t [k] = #t' [k]) -> - exchange t t' i j. - -(* Properties about exchanges *) - -Lemma exchange_1 : - forall (n:Z) (A:Set) (t:array n A) (i j:Z), - (0 <= i < n)%Z -> - (0 <= j < n)%Z -> #(store (store t i #t [j]) j #t [i]) [i] = #t [j]. -Proof. -intros n A t i j H_i H_j. -case (dec_eq j i). -intro eq_i_j. rewrite eq_i_j. -auto with datatypes. -intro not_j_i. -rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_i not_j_i). -auto with datatypes. -Qed. - -Hint Resolve exchange_1: v62 datatypes. - - -Lemma exchange_proof : - forall (n:Z) (A:Set) (t:array n A) (i j:Z), - (0 <= i < n)%Z -> - (0 <= j < n)%Z -> exchange (store (store t i #t [j]) j #t [i]) t i j. -Proof. -intros n A t i j H_i H_j. -apply exchange_c; auto with datatypes. -intros k H_k not_k_i not_k_j. -cut (j <> k); auto with datatypes. intro not_j_k. -rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_k not_j_k). -auto with datatypes. -Qed. - -Hint Resolve exchange_proof: v62 datatypes. - - -Lemma exchange_sym : - forall (n:Z) (A:Set) (t t':array n A) (i j:Z), - exchange t t' i j -> exchange t' t i j. -Proof. -intros n A t t' i j H1. -elim H1. clear H1. intros. -constructor 1; auto with datatypes. -intros. rewrite (H3 k); auto with datatypes. -Qed. - -Hint Resolve exchange_sym: v62 datatypes. - - -Lemma exchange_id : - forall (n:Z) (A:Set) (t t':array n A) (i j:Z), - exchange t t' i j -> - i = j -> forall k:Z, (0 <= k < n)%Z -> #t [k] = #t' [k]. -Proof. -intros n A t t' i j Hex Heq k Hk. -elim Hex. clear Hex. intros. -rewrite Heq in H1. rewrite Heq in H2. -case (Z_eq_dec k j). - intro Heq'. rewrite Heq'. assumption. - intro Hnoteq. apply (H3 k); auto with datatypes. rewrite Heq. assumption. -Qed. - -Hint Resolve exchange_id: v62 datatypes.
\ No newline at end of file diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v deleted file mode 100644 index 38448efc..00000000 --- a/contrib/correctness/ProgBool.v +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ProgBool.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Import ZArith. -Require Export Bool_nat. -Require Export Sumbool. - -Definition annot_bool : - forall b:bool, {b' : bool | if b' then b = true else b = false}. -Proof. -intro b. -exists b. case b; trivial. -Qed. - - -(* Logical connectives *) - -Definition spec_and (A B C D:Prop) (b:bool) := if b then A /\ C else B \/ D. - -Definition prog_bool_and : - forall Q1 Q2:bool -> Prop, - sig Q1 -> - sig Q2 -> - {b : bool | if b then Q1 true /\ Q2 true else Q1 false \/ Q2 false}. -Proof. -intros Q1 Q2 H1 H2. -elim H1. intro b1. elim H2. intro b2. -case b1; case b2; intros. -exists true; auto. -exists false; auto. exists false; auto. exists false; auto. -Qed. - -Definition spec_or (A B C D:Prop) (b:bool) := if b then A \/ C else B /\ D. - -Definition prog_bool_or : - forall Q1 Q2:bool -> Prop, - sig Q1 -> - sig Q2 -> - {b : bool | if b then Q1 true \/ Q2 true else Q1 false /\ Q2 false}. -Proof. -intros Q1 Q2 H1 H2. -elim H1. intro b1. elim H2. intro b2. -case b1; case b2; intros. -exists true; auto. exists true; auto. exists true; auto. -exists false; auto. -Qed. - -Definition spec_not (A B:Prop) (b:bool) := if b then B else A. - -Definition prog_bool_not : - forall Q:bool -> Prop, sig Q -> {b : bool | if b then Q false else Q true}. -Proof. -intros Q H. -elim H. intro b. -case b; intro. -exists false; auto. exists true; auto. -Qed. diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v deleted file mode 100644 index b1eaaea7..00000000 --- a/contrib/correctness/ProgInt.v +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ProgInt.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export ZArith. -Require Export ZArith_dec. - -Theorem Znotzero : forall x:Z, {x <> 0%Z} + {x = 0%Z}. -Proof. -intro x. elim (Z_eq_dec x 0); auto. -Qed.
\ No newline at end of file diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v deleted file mode 100644 index 70f4b730..00000000 --- a/contrib/correctness/ProgramsExtraction.v +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *) - -Extract Inductive unit => unit [ "()" ]. -Extract Inductive bool => bool [ true false ]. -Extract Inductive sumbool => bool [ true false ]. - -Require Export Correctness. - -Declare ML Module "pextract". - -Grammar vernac vernac : ast := - imperative_ocaml [ "Write" "Caml" "File" stringarg($file) - "[" ne_identarg_list($idl) "]" "." ] - -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ] - -| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ] - -> [ (INITIALIZE $id $c) ] -. diff --git a/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v deleted file mode 100644 index 6489de81..00000000 --- a/contrib/correctness/Programs_stuff.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Programs_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export Arrays_stuff. diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v deleted file mode 100644 index ca4ed880..00000000 --- a/contrib/correctness/Sorted.v +++ /dev/null @@ -1,202 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *) - -(* $Id: Sorted.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export Arrays. -Require Import ArrayPermut. - -Require Import ZArithRing. -Require Import Omega. -Open Local Scope Z_scope. - -Set Implicit Arguments. - -(* Definition *) - -Definition sorted_array (N:Z) (A:array N Z) (deb fin:Z) := - deb <= fin -> forall x:Z, x >= deb -> x < fin -> #A [x] <= #A [x + 1]. - -(* Elements of a sorted sub-array are in increasing order *) - -(* one element and the next one *) - -Lemma sorted_elements_1 : - forall (N:Z) (A:array N Z) (n m:Z), - sorted_array A n m -> - forall k:Z, - k >= n -> forall i:Z, 0 <= i -> k + i <= m -> #A [k] <= #A [k + i]. -Proof. -intros N A n m H_sorted k H_k i H_i. -pattern i in |- *. apply natlike_ind. -intro. -replace (k + 0) with k; omega. (*** Ring `k+0` => BUG ***) - -intros. -apply Zle_trans with (m := #A [k + x]). -apply H0; omega. - -unfold Zsucc in |- *. -replace (k + (x + 1)) with (k + x + 1). -unfold sorted_array in H_sorted. -apply H_sorted; omega. - -omega. - -assumption. -Qed. - -(* one element and any of the following *) - -Lemma sorted_elements : - forall (N:Z) (A:array N Z) (n m k l:Z), - sorted_array A n m -> - k >= n -> l < N -> k <= l -> l <= m -> #A [k] <= #A [l]. -Proof. -intros. -replace l with (k + (l - k)). -apply sorted_elements_1 with (n := n) (m := m); - [ assumption | omega | omega | omega ]. -omega. -Qed. - -Hint Resolve sorted_elements: datatypes v62. - -(* A sub-array of a sorted array is sorted *) - -Lemma sub_sorted_array : - forall (N:Z) (A:array N Z) (deb fin i j:Z), - sorted_array A deb fin -> - i >= deb -> j <= fin -> i <= j -> sorted_array A i j. -Proof. -unfold sorted_array in |- *. -intros. -apply H; omega. -Qed. - -Hint Resolve sub_sorted_array: datatypes v62. - -(* Extension on the left of the property of being sorted *) - -Lemma left_extension : - forall (N:Z) (A:array N Z) (i j:Z), - i > 0 -> - j < N -> - sorted_array A i j -> #A [i - 1] <= #A [i] -> sorted_array A (i - 1) j. -Proof. -intros; unfold sorted_array in |- *; intros. -elim (Z_ge_lt_dec x i). (* (`x >= i`) + (`x < i`) *) -intro Hcut. -apply H1; omega. - -intro Hcut. -replace x with (i - 1). -replace (i - 1 + 1) with i; [ assumption | omega ]. - -omega. -Qed. - -(* Extension on the right *) - -Lemma right_extension : - forall (N:Z) (A:array N Z) (i j:Z), - i >= 0 -> - j < N - 1 -> - sorted_array A i j -> #A [j] <= #A [j + 1] -> sorted_array A i (j + 1). -Proof. -intros; unfold sorted_array in |- *; intros. -elim (Z_lt_ge_dec x j). -intro Hcut. -apply H1; omega. - -intro HCut. -replace x with j; [ assumption | omega ]. -Qed. - -(* Substitution of the leftmost value by a smaller value *) - -Lemma left_substitution : - forall (N:Z) (A:array N Z) (i j v:Z), - i >= 0 -> - j < N -> - sorted_array A i j -> v <= #A [i] -> sorted_array (store A i v) i j. -Proof. -intros N A i j v H_i H_j H_sorted H_v. -unfold sorted_array in |- *; intros. - -cut (x = i \/ x > i). -intro Hcut; elim Hcut; clear Hcut; intro. -rewrite H2. -rewrite store_def_1; try omega. -rewrite store_def_2; try omega. -apply Zle_trans with (m := #A [i]); [ assumption | apply H_sorted; omega ]. - -rewrite store_def_2; try omega. -rewrite store_def_2; try omega. -apply H_sorted; omega. -omega. -Qed. - -(* Substitution of the rightmost value by a larger value *) - -Lemma right_substitution : - forall (N:Z) (A:array N Z) (i j v:Z), - i >= 0 -> - j < N -> - sorted_array A i j -> #A [j] <= v -> sorted_array (store A j v) i j. -Proof. -intros N A i j v H_i H_j H_sorted H_v. -unfold sorted_array in |- *; intros. - -cut (x = j - 1 \/ x < j - 1). -intro Hcut; elim Hcut; clear Hcut; intro. -rewrite H2. -replace (j - 1 + 1) with j; [ idtac | omega ]. (*** Ring `j-1+1`. => BUG ***) -rewrite store_def_2; try omega. -rewrite store_def_1; try omega. -apply Zle_trans with (m := #A [j]). -apply sorted_elements with (n := i) (m := j); try omega; assumption. -assumption. - -rewrite store_def_2; try omega. -rewrite store_def_2; try omega. -apply H_sorted; omega. - -omega. -Qed. - -(* Affectation outside of the sorted region *) - -Lemma no_effect : - forall (N:Z) (A:array N Z) (i j k v:Z), - i >= 0 -> - j < N -> - sorted_array A i j -> - 0 <= k < i \/ j < k < N -> sorted_array (store A k v) i j. -Proof. -intros. -unfold sorted_array in |- *; intros. -rewrite store_def_2; try omega. -rewrite store_def_2; try omega. -apply H1; assumption. -Qed. - -Lemma sorted_array_id : - forall (N:Z) (t1 t2:array N Z) (g d:Z), - sorted_array t1 g d -> array_id t1 t2 g d -> sorted_array t2 g d. -Proof. -intros N t1 t2 g d Hsorted Hid. -unfold array_id in Hid. -unfold sorted_array in Hsorted. unfold sorted_array in |- *. -intros Hgd x H1x H2x. -rewrite <- (Hid x); [ idtac | omega ]. -rewrite <- (Hid (x + 1)); [ idtac | omega ]. -apply Hsorted; assumption. -Qed.
\ No newline at end of file diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v deleted file mode 100644 index c7071f32..00000000 --- a/contrib/correctness/Tuples.v +++ /dev/null @@ -1,98 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Tuples.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -(* Tuples *) - -Definition tuple_1 (X:Set) := X. -Definition tuple_2 := prod. -Definition Build_tuple_2 := pair. -Definition proj_2_1 := fst. -Definition proj_2_2 := snd. - -Record tuple_3 (T1 T2 T3:Set) : Set := - {proj_3_1 : T1; proj_3_2 : T2; proj_3_3 : T3}. - -Record tuple_4 (T1 T2 T3 T4:Set) : Set := - {proj_4_1 : T1; proj_4_2 : T2; proj_4_3 : T3; proj_4_4 : T4}. - -Record tuple_5 (T1 T2 T3 T4 T5:Set) : Set := - {proj_5_1 : T1; proj_5_2 : T2; proj_5_3 : T3; proj_5_4 : T4; proj_5_5 : T5}. - -Record tuple_6 (T1 T2 T3 T4 T5 T6:Set) : Set := - {proj_6_1 : T1; - proj_6_2 : T2; - proj_6_3 : T3; - proj_6_4 : T4; - proj_6_5 : T5; - proj_6_6 : T6}. - -Record tuple_7 (T1 T2 T3 T4 T5 T6 T7:Set) : Set := - {proj_7_1 : T1; - proj_7_2 : T2; - proj_7_3 : T3; - proj_7_4 : T4; - proj_7_5 : T5; - proj_7_6 : T6; - proj_7_7 : T7}. - - -(* Existentials *) - -Definition sig_1 := sig. -Definition exist_1 := exist. - -Inductive sig_2 (T1 T2:Set) (P:T1 -> T2 -> Prop) : Set := - exist_2 : forall (x1:T1) (x2:T2), P x1 x2 -> sig_2 T1 T2 P. - -Inductive sig_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Prop) : Set := - exist_3 : forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> sig_3 T1 T2 T3 P. - - -Inductive sig_4 (T1 T2 T3 T4:Set) (P:T1 -> T2 -> T3 -> T4 -> Prop) : Set := - exist_4 : - forall (x1:T1) (x2:T2) (x3:T3) (x4:T4), - P x1 x2 x3 x4 -> sig_4 T1 T2 T3 T4 P. - -Inductive sig_5 (T1 T2 T3 T4 T5:Set) (P:T1 -> T2 -> T3 -> T4 -> T5 -> Prop) : -Set := - exist_5 : - forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5), - P x1 x2 x3 x4 x5 -> sig_5 T1 T2 T3 T4 T5 P. - -Inductive sig_6 (T1 T2 T3 T4 T5 T6:Set) -(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> Prop) : Set := - exist_6 : - forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) - (x6:T6), P x1 x2 x3 x4 x5 x6 -> sig_6 T1 T2 T3 T4 T5 T6 P. - -Inductive sig_7 (T1 T2 T3 T4 T5 T6 T7:Set) -(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> Prop) : Set := - exist_7 : - forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) - (x6:T6) (x7:T7), - P x1 x2 x3 x4 x5 x6 x7 -> sig_7 T1 T2 T3 T4 T5 T6 T7 P. - -Inductive sig_8 (T1 T2 T3 T4 T5 T6 T7 T8:Set) -(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> T8 -> Prop) : Set := - exist_8 : - forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) - (x6:T6) (x7:T7) (x8:T8), - P x1 x2 x3 x4 x5 x6 x7 x8 -> sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P. - -Inductive dep_tuple_2 (T1 T2:Set) (P:T1 -> T2 -> Set) : Set := - Build_dep_tuple_2 : - forall (x1:T1) (x2:T2), P x1 x2 -> dep_tuple_2 T1 T2 P. - -Inductive dep_tuple_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Set) : Set := - Build_dep_tuple_3 : - forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> dep_tuple_3 T1 T2 T3 P. - diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v deleted file mode 100644 index abb1cc76..00000000 --- a/contrib/correctness/examples/Handbook.v +++ /dev/null @@ -1,232 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: Handbook.v 1577 2001-04-11 07:56:19Z filliatr $ *) - -(* This file contains proofs of programs taken from the - * "Handbook of Theoretical Computer Science", volume B, - * chapter "Methods and Logics for Proving Programs", by P. Cousot, - * pp 841--993, Edited by J. van Leeuwen (c) Elsevier Science Publishers B.V. - * 1990. - * - * Programs are refered to by numbers and pages. - *) - -Require Correctness. - -Require Sumbool. -Require Omega. -Require Zcomplements. -Require Zpower. - -(****************************************************************************) - -(* program (2) page 853 to compute x^y (annotated version is (25) page 860) *) - -(* en attendant... *) -Parameter Zdiv2 : Z->Z. - -Parameter Zeven_odd_dec : (x:Z){`x=2*(Zdiv2 x)`}+{`x=2*(Zdiv2 x)+1`}. -Definition Zodd_dec := [z:Z](sumbool_not ? ? (Zeven_odd_dec z)). -Definition Zodd_bool := [z:Z](bool_of_sumbool ? ? (Zodd_dec z)). - -Axiom axiom1 : (x,y:Z) `y>0` -> `x*(Zpower x (Zpred y)) = (Zpower x y)`. -Axiom axiom2 : (x:Z)`x>0` -> `(Zdiv2 x)<x`. -Axiom axiom3 : (x,y:Z) `y>=0` -> `(Zpower (x*x) (Zdiv2 y)) = (Zpower x y)`. - -Global Variable X : Z ref. -Global Variable Y : Z ref. -Global Variable Z_ : Z ref. - -Correctness pgm25 - { `Y >= 0` } - begin - Z_ := 1; - while !Y <> 0 do - { invariant `Y >= 0` /\ `Z_ * (Zpower X Y) = (Zpower X@0 Y@0)` - variant Y } - if (Zodd_bool !Y) then begin - Y := (Zpred !Y); - Z_ := (Zmult !Z_ !X) - end else begin - Y := (Zdiv2 !Y); - X := (Zmult !X !X) - end - done - end - { Z_ = (Zpower X@ Y@) }. -Proof. -Split. -Unfold Zpred; Unfold Zwf; Omega. -Split. -Unfold Zpred; Omega. -Decompose [and] Pre2. -Rewrite <- H0. -Replace `Z_1*X0*(Zpower X0 (Zpred Y0))` with `Z_1*(X0*(Zpower X0 (Zpred Y0)))`. -Apply f_equal with f := (Zmult Z_1). -Apply axiom1. -Omega. - -Auto. -Symmetry. -Apply Zmult_assoc_r. - -Split. -Unfold Zwf. -Repeat (Apply conj). -Omega. - -Omega. - -Apply axiom2. Omega. - -Split. -Omega. - -Decompose [and] Pre2. -Rewrite <- H0. -Apply f_equal with f:=(Zmult Z_1). -Apply axiom3. Omega. - -Omega. - -Decompose [and] Post6. -Rewrite <- H2. -Rewrite H0. -Simpl. -Omega. - -Save. - - -(****************************************************************************) - -(* program (178) page 934 to compute the factorial using global variables - * annotated version is (185) page 939 - *) - -Parameter Zfact : Z -> Z. - -Axiom axiom4 : `(Zfact 0) = 1`. -Axiom axiom5 : (x:Z) `x>0` -> `(Zfact (x-1))*x=(Zfact x)`. - -Correctness pgm178 -let rec F (u:unit) : unit { variant X } = - { `X>=0` } - (if !X = 0 then - Y := 1 - else begin - label L; - X := (Zpred !X); - (F tt); - X := (Zs !X); - Y := (Zmult !Y !X) - end) - { `X=X@` /\ `Y=(Zfact X@)` }. -Proof. -Rewrite Test1. Rewrite axiom4. Auto. -Unfold Zwf. Unfold Zpred. Omega. -Unfold Zpred. Omega. -Unfold Zs. Unfold Zpred in Post3. Split. -Omega. -Decompose [and] Post3. -Rewrite H. -Replace `X0+(-1)+1` with X0. -Rewrite H0. -Replace `X0+(-1)` with `X0-1`. -Apply axiom5. -Omega. -Omega. -Omega. -Save. - - -(****************************************************************************) - -(* program (186) page 939 "showing the usefulness of auxiliary variables" ! *) - -Global Variable N : Z ref. -Global Variable S : Z ref. - -Correctness pgm186 -let rec F (u:unit) : unit { variant N } = - { `N>=0` } - (if !N > 0 then begin - label L; - N := (Zpred !N); - (F tt); - S := (Zs !S); - (F tt); - N := (Zs !N) - end) - { `N=N@` /\ `S=S@+(Zpower 2 N@)-1` }. -Proof. -Unfold Zwf. Unfold Zpred. Omega. -Unfold Zpred. Omega. -Decompose [and] Post5. Rewrite H. Unfold Zwf. Unfold Zpred. Omega. -Decompose [and] Post5. Rewrite H. Unfold Zpred. Omega. -Split. -Unfold Zpred in Post5. Omega. -Decompose [and] Post4. Rewrite H0. -Decompose [and] Post5. Rewrite H2. Rewrite H1. -Replace `(Zpower 2 N0)` with `2*(Zpower 2 (Zpred N0))`. Omega. -Symmetry. -Replace `(Zpower 2 N0)` with `(Zpower 2 (1+(Zpred N0)))`. -Replace `2*(Zpower 2 (Zpred N0))` with `(Zpower 2 1)*(Zpower 2 (Zpred N0))`. -Apply Zpower_exp. -Omega. -Unfold Zpred. Omega. -Auto. -Replace `(1+(Zpred N0))` with N0; [ Auto | Unfold Zpred; Omega ]. -Split. -Auto. -Replace N0 with `0`; Simpl; Omega. -Save. - - -(****************************************************************************) - -(* program (196) page 944 (recursive factorial procedure with value-result - * parameters) - *) - -Correctness pgm196 -let rec F (U:Z) (V:Z ref) : unit { variant U } = - { `U >= 0` } - (if U = 0 then - V := 1 - else begin - (F (Zpred U) V); - V := (Zmult !V U) - end) - { `V = (Zfact U)` }. -Proof. -Symmetry. Rewrite Test1. Apply axiom4. -Unfold Zwf. Unfold Zpred. Omega. -Unfold Zpred. Omega. -Rewrite Post3. -Unfold Zpred. Replace `U0+(-1)` with `U0-1`. Apply axiom5. -Omega. -Omega. -Save. - -(****************************************************************************) - -(* program (197) page 945 (L_4 subset of Pascal) *) - -(* -procedure P(X:Z; procedure Q(Z:Z)); - procedure L(X:Z); begin Q(X-1) end; - begin if X>0 then P(X-1,L) else Q(X) end; - -procedure M(N:Z); - procedure R(X:Z); begin writeln(X) (* => RES := !X *) end; - begin P(N,R) end. -*) diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v deleted file mode 100644 index 3142e906..00000000 --- a/contrib/correctness/examples/exp.v +++ /dev/null @@ -1,204 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(*i $Id: exp.v 1577 2001-04-11 07:56:19Z filliatr $ i*) - -(* Efficient computation of X^n using - * - * X^(2n) = (X^n) ^ 2 - * X^(2n+1) = X . (X^n) ^ 2 - * - * Proofs of both fonctional and imperative programs. - *) - -Require Even. -Require Div2. -Require Correctness. -Require ArithRing. -Require ZArithRing. - -(* The specification uses the traditional definition of X^n *) - -Fixpoint power [x,n:nat] : nat := - Cases n of - O => (S O) - | (S n') => (mult x (power x n')) - end. - -Definition square := [n:nat](mult n n). - - -(* Three lemmas are necessary to establish the forthcoming proof obligations *) - -(* n = 2*(n/2) => (x^(n/2))^2 = x^n *) - -Lemma exp_div2_0 : (x,n:nat) - n=(double (div2 n)) - -> (square (power x (div2 n)))=(power x n). -Proof. -Unfold square. -Intros x n. Pattern n. Apply ind_0_1_SS. -Auto. - -Intro. (Absurd (1)=(double (0)); Auto). - -Intros. Simpl. -Cut n0=(double (div2 n0)). -Intro. Rewrite <- (H H1). -Ring. - -Simpl in H0. -Unfold double in H0. -Simpl in H0. -Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0. -(Injection H0; Auto). -Save. - -(* n = 2*(n/2)+1 => x*(x^(n/2))^2 = x^n *) - -Lemma exp_div2_1 : (x,n:nat) - n=(S (double (div2 n))) - -> (mult x (square (power x (div2 n))))=(power x n). -Proof. -Unfold square. -Intros x n. Pattern n. Apply ind_0_1_SS. - -Intro. (Absurd (0)=(S (double (0))); Auto). - -Auto. - -Intros. Simpl. -Cut n0=(S (double (div2 n0))). -Intro. Rewrite <- (H H1). -Ring. - -Simpl in H0. -Unfold double in H0. -Simpl in H0. -Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0. -(Injection H0; Auto). -Save. - -(* x^(2*n) = (x^2)^n *) - -Lemma power_2n : (x,n:nat)(power x (double n))=(power (square x) n). -Proof. -Unfold double. Unfold square. -Induction n. -Auto. - -Intros. -Simpl. -Rewrite <- H. -Rewrite <- (plus_n_Sm n0 n0). -Simpl. -Auto with arith. -Save. - -Hints Resolve exp_div2_0 exp_div2_1. - - -(* Functional version. - * - * Here we give the functional program as an incomplete CIC term, - * using the tactic Refine. - * - * On this example, it really behaves as the tactic Program. - *) - -(* -Lemma f_exp : (x,n:nat) { y:nat | y=(power x n) }. -Proof. -Refine [x:nat] - (well_founded_induction nat lt lt_wf - [n:nat]{y:nat | y=(power x n) } - [n:nat] - [f:(p:nat)(lt p n)->{y:nat | y=(power x p) }] - Cases (zerop n) of - (left _) => (exist ? ? (S O) ?) - | (right _) => - let (y,H) = (f (div2 n) ?) in - Cases (even_odd_dec n) of - (left _) => (exist ? ? (mult y y) ?) - | (right _) => (exist ? ? (mult x (mult y y)) ?) - end - end). -Proof. -Rewrite a. Auto. -Exact (lt_div2 n a). -Change (square y)=(power x n). Rewrite H. Auto with arith. -Change (mult x (square y))=(power x n). Rewrite H. Auto with arith. -Save. -*) - -(* Imperative version. *) - -Definition even_odd_bool := [x:nat](bool_of_sumbool ? ? (even_odd_dec x)). - -Correctness i_exp - fun (x:nat)(n:nat) -> - let y = ref (S O) in - let m = ref x in - let e = ref n in - begin - while (notzerop_bool !e) do - { invariant (power x n)=(mult y (power m e)) as Inv - variant e for lt } - (if not (even_odd_bool !e) then y := (mult !y !m)) - { (power x n) = (mult y (power m (double (div2 e)))) as Q }; - m := (square !m); - e := (div2 !e) - done; - !y - end - { result=(power x n) } -. -Proof. -Rewrite (odd_double e0 Test1) in Inv. Rewrite Inv. Simpl. Auto with arith. - -Rewrite (even_double e0 Test1) in Inv. Rewrite Inv. Reflexivity. - -Split. -Exact (lt_div2 e0 Test2). - -Rewrite Q. Unfold double. Unfold square. -Simpl. -Change (mult y1 (power m0 (double (div2 e0)))) - = (mult y1 (power (square m0) (div2 e0))). -Rewrite (power_2n m0 (div2 e0)). Reflexivity. - -Auto with arith. - -Decompose [and] Inv. -Rewrite H. Rewrite H0. -Auto with arith. -Save. - - -(* Recursive version. *) - -Correctness r_exp - let rec exp (x:nat) (n:nat) : nat { variant n for lt} = - (if (zerop_bool n) then - (S O) - else - let y = (exp x (div2 n)) in - if (even_odd_bool n) then - (mult y y) - else - (mult x (mult y y)) - ) { result=(power x n) } -. -Proof. -Rewrite Test2. Auto. -Exact (lt_div2 n0 Test2). -Change (square y)=(power x0 n0). Rewrite Post7. Auto with arith. -Change (mult x0 (square y))=(power x0 n0). Rewrite Post7. Auto with arith. -Save. diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v deleted file mode 100644 index 044263ca..00000000 --- a/contrib/correctness/examples/exp_int.v +++ /dev/null @@ -1,218 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: exp_int.v 1577 2001-04-11 07:56:19Z filliatr $ *) - -(* Efficient computation of X^n using - * - * X^(2n) = (X^n) ^ 2 - * X^(2n+1) = X . (X^n) ^ 2 - * - * Proofs of both fonctional and imperative programs. - *) - -Require Zpower. -Require Zcomplements. - -Require Correctness. -Require ZArithRing. -Require Omega. - -Definition Zdouble := [n:Z]`2*n`. - -Definition Zsquare := [n:Z](Zmult n n). - -(* Some auxiliary lemmas about Zdiv2 are necessary *) - -Lemma Zdiv2_ge_0 : (x:Z) `x >= 0` -> `(Zdiv2 x) >= 0`. -Proof. -Destruct x; Auto with zarith. -Destruct p; Auto with zarith. -Simpl. Omega. -Intros. (Absurd `(NEG p) >= 0`; Red; Auto with zarith). -Save. - -Lemma Zdiv2_lt : (x:Z) `x > 0` -> `(Zdiv2 x) < x`. -Proof. -Destruct x. -Intro. Absurd `0 > 0`; [ Omega | Assumption ]. -Destruct p; Auto with zarith. - -Simpl. -Intro p0. -Replace (POS (xI p0)) with `2*(POS p0)+1`. -Omega. -Simpl. Auto with zarith. - -Intro p0. -Simpl. -Replace (POS (xO p0)) with `2*(POS p0)`. -Omega. -Simpl. Auto with zarith. - -Simpl. Omega. - -Intros. -Absurd `(NEG p) > 0`; Red; Auto with zarith. -Elim p; Auto with zarith. -Omega. -Save. - -(* A property of Zpower: x^(2*n) = (x^2)^n *) - -Lemma Zpower_2n : - (x,n:Z)`n >= 0` -> (Zpower x (Zdouble n))=(Zpower (Zsquare x) n). -Proof. -Unfold Zdouble. -Intros x n Hn. -Replace `2*n` with `n+n`. -Rewrite Zpower_exp. -Pattern n. -Apply natlike_ind. - -Simpl. Auto with zarith. - -Intros. -Unfold Zs. -Rewrite Zpower_exp. -Rewrite Zpower_exp. -Replace (Zpower x `1`) with x. -Replace (Zpower (Zsquare x) `1`) with (Zsquare x). -Rewrite <- H0. -Unfold Zsquare. -Ring. - -Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. - -Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. - -Omega. -Omega. -Omega. -Omega. -Omega. -Assumption. -Assumption. -Omega. -Save. - - -(* The program *) - -Correctness i_exp - fun (x:Z)(n:Z) -> - { `n >= 0` } - (let y = ref 1 in - let m = ref x in - let e = ref n in - begin - while !e > 0 do - { invariant (Zpower x n)=(Zmult y (Zpower m e)) /\ `e>=0` as Inv - variant e } - (if not (Zeven_odd_bool !e) then y := (Zmult !y !m)) - { (Zpower x n) = (Zmult y (Zpower m (Zdouble (Zdiv2 e)))) as Q }; - m := (Zsquare !m); - e := (Zdiv2 !e) - done; - !y - end) - { result=(Zpower x n) } -. -Proof. -(* Zodd *) -Decompose [and] Inv. -Rewrite (Zodd_div2 e0 H0 Test1) in H. Rewrite H. -Rewrite Zpower_exp. -Unfold Zdouble. -Replace (Zpower m0 `1`) with m0. -Ring. -Unfold Zpower; Unfold Zpower_pos; Simpl; Ring. -Generalize (Zdiv2_ge_0 e0); Omega. -Omega. -(* Zeven *) -Decompose [and] Inv. -Rewrite (Zeven_div2 e0 Test1) in H. Rewrite H. -Auto with zarith. -Split. -(* Zwf *) -Unfold Zwf. -Repeat Split. -Generalize (Zdiv2_ge_0 e0); Omega. -Omega. -Exact (Zdiv2_lt e0 Test2). -(* invariant *) -Split. -Rewrite Q. Unfold Zdouble. Unfold Zsquare. -Rewrite (Zpower_2n). -Trivial. -Generalize (Zdiv2_ge_0 e0); Omega. -Generalize (Zdiv2_ge_0 e0); Omega. -Split; [ Ring | Assumption ]. -(* exit fo loop *) -Decompose [and] Inv. -Cut `e0 = 0`. Intro. -Rewrite H1. Rewrite H. -Simpl; Ring. -Omega. -Save. - - -(* Recursive version. *) - -Correctness r_exp - let rec exp (x:Z) (n:Z) : Z { variant n } = - { `n >= 0` } - (if n = 0 then - 1 - else - let y = (exp x (Zdiv2 n)) in - (if (Zeven_odd_bool n) then - (Zmult y y) - else - (Zmult x (Zmult y y))) { result=(Zpower x n) as Q } - ) - { result=(Zpower x n) } -. -Proof. -Rewrite Test2. Auto with zarith. -(* w.f. *) -Unfold Zwf. -Repeat Split. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Omega. -Generalize (Zdiv2_lt n0) ; Omega. -(* rec. call *) -Generalize (Zdiv2_ge_0 n0) ; Omega. -(* invariant: case even *) -Generalize (Zeven_div2 n0 Test1). -Intro Heq. Rewrite Heq. -Rewrite Post4. -Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`. -Rewrite Zpower_exp. -Auto with zarith. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Omega. -(* invariant: cas odd *) -Generalize (Zodd_div2 n0 Pre1 Test1). -Intro Heq. Rewrite Heq. -Rewrite Post4. -Rewrite Zpower_exp. -Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`. -Rewrite Zpower_exp. -Replace `(Zpower x0 1)` with x0. -Ring. -Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Omega. -Generalize (Zdiv2_ge_0 n0) ; Omega. -Omega. -Save. diff --git a/contrib/correctness/examples/extract.v b/contrib/correctness/examples/extract.v deleted file mode 100644 index e225ba18..00000000 --- a/contrib/correctness/examples/extract.v +++ /dev/null @@ -1,43 +0,0 @@ - -(* Tests d'extraction *) - -Require ProgramsExtraction. -Save State Ici "test extraction". - -(* exp *) - -Require exp. -Write Caml File "exp" [ i_exp r_exp ]. - -(* exp_int *) - -Restore State Ici. -Require exp_int. -Write Caml File "exp_int" [ i_exp r_exp ]. - -(* fact *) - -Restore State Ici. -Require fact. -Initialize x with (S (S (S O))). -Initialize y with O. -Write Caml File "fact" [ factorielle ]. - -(* fact_int *) - -Restore State Ici. -Require fact_int. -Initialize x with `3`. -Initialize y with `0`. -Write Caml File "fact_int" [ factorielle ]. - -(* Handbook *) - -Restore State Ici. -Require Handbook. -Initialize X with `3`. -Initialize Y with `3`. -Initialize Z with `3`. -Initialize N with `3`. -Initialize S with `3`. -Write Caml File "Handbook" [ pgm178 pgm186 pgm196 ]. diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v deleted file mode 100644 index 07e77140..00000000 --- a/contrib/correctness/examples/fact.v +++ /dev/null @@ -1,69 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: fact.v 1577 2001-04-11 07:56:19Z filliatr $ *) - -(* Proof of an imperative program computing the factorial (over type nat) *) - -Require Correctness. -Require Omega. -Require Arith. - -Fixpoint fact [n:nat] : nat := - Cases n of - O => (S O) - | (S p) => (mult n (fact p)) - end. - -(* (x * y) * (x-1)! = y * x! *) - -Lemma fact_rec : (x,y:nat)(lt O x) -> - (mult (mult x y) (fact (pred x))) = (mult y (fact x)). -Proof. -Intros x y H. -Generalize (mult_sym x y). Intro H1. Rewrite H1. -Generalize (mult_assoc_r y x (fact (pred x))). Intro H2. Rewrite H2. -Apply (f_equal nat nat [x:nat](mult y x)). -Generalize H. Elim x; Auto with arith. -Save. - - -(* we declare two variables x and y *) - -Global Variable x : nat ref. -Global Variable y : nat ref. - -(* we give the annotated program *) - -Correctness factorielle - begin - y := (S O); - while (notzerop_bool !x) do - { invariant (mult y (fact x)) = (fact x@0) as I - variant x for lt } - y := (mult !x !y); - x := (pred !x) - done - end - { y = (fact x@0) }. -Proof. -Split. -(* decreasing of the variant *) -Omega. -(* preservation of the invariant *) -Rewrite <- I. Exact (fact_rec x0 y1 Test1). -(* entrance of loop *) -Auto with arith. -(* exit of loop *) -Elim I. Intros H1 H2. -Rewrite H2 in H1. -Rewrite <- H1. -Auto with arith. -Save. diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v deleted file mode 100644 index f463ca80..00000000 --- a/contrib/correctness/examples/fact_int.v +++ /dev/null @@ -1,195 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) - -(* $Id: fact_int.v 1577 2001-04-11 07:56:19Z filliatr $ *) - -(* Proof of an imperative program computing the factorial (over type Z) *) - -Require Correctness. -Require Omega. -Require ZArithRing. - -(* We define the factorial as a relation... *) - -Inductive fact : Z -> Z -> Prop := - fact_0 : (fact `0` `1`) - | fact_S : (z,f:Z) (fact z f) -> (fact (Zs z) (Zmult (Zs z) f)). - -(* ...and then we prove that it contains a function *) - -Lemma fact_function : (z:Z) `0 <= z` -> (EX f:Z | (fact z f)). -Proof. -Intros. -Apply natlike_ind with P:=[z:Z](EX f:Z | (fact z f)). -Split with `1`. -Exact fact_0. - -Intros. -Elim H1. -Intros. -Split with `(Zs x)*x0`. -Exact (fact_S x x0 H2). - -Assumption. -Save. - -(* This lemma should belong to the ZArith library *) - -Lemma Z_mult_1 : (x,y:Z)`x>=1`->`y>=1`->`x*y>=1`. -Proof. -Intros. -Generalize H. -Apply natlike_ind with P:=[x:Z]`x >= 1`->`x*y >= 1`. -Omega. - -Intros. -Simpl. -Elim (Z_le_lt_eq_dec `0` x0 H1). -Simpl. -Unfold Zs. -Replace `(x0+1)*y` with `x0*y+y`. -Generalize H2. -Generalize `x0*y`. -Intro. -Intros. -Omega. - -Ring. - -Intros. -Rewrite <- b. -Omega. - -Omega. -Save. - -(* (fact x f) implies x>=0 and f>=1 *) - -Lemma fact_pos : (x,f:Z)(fact x f)-> `x>=0` /\ `f>=1`. -Proof. -Intros. -(Elim H; Auto). -Omega. - -Intros. -(Split; Try Omega). -(Apply Z_mult_1; Try Omega). -Save. - -(* (fact 0 x) implies x=1 *) - -Lemma fact_0_1 : (x:Z)(fact `0` x) -> `x=1`. -Proof. -Intros. -Inversion H. -Reflexivity. - -Elim (fact_pos z f H1). -Intros. -(Absurd `z >= 0`; Omega). -Save. - - -(* We define the loop invariant : y * x! = x0! *) - -Inductive invariant [y,x,x0:Z] : Prop := - c_inv : (f,f0:Z)(fact x f)->(fact x0 f0)->(Zmult y f)=f0 - -> (invariant y x x0). - -(* The following lemma is used to prove the preservation of the invariant *) - -Lemma fact_rec : (x0,x,y:Z)`0 < x` -> - (invariant y x x0) - -> (invariant `x*y` (Zpred x) x0). -Proof. -Intros x0 x y H H0. -Elim H0. -Intros. -Generalize H H0 H3. -Elim H1. -Intros. -Absurd `0 < 0`; Omega. - -Intros. -Apply c_inv with f:=f1 f0:=f0. -Cut `z+1+-1 = z`. Intro eq_z. Rewrite <- eq_z in H4. -Assumption. - -Omega. - -Assumption. - -Rewrite (Zmult_sym (Zs z) y). -Rewrite (Zmult_assoc_r y (Zs z) f1). -Auto. -Save. - - -(* This one is used to prove the proof obligation at the exit of the loop *) - -Lemma invariant_0 : (x,y:Z)(invariant y `0` x)->(fact x y). -Proof. -Intros. -Elim H. -Intros. -Generalize (fact_0_1 f H0). -Intro. -Rewrite H3 in H2. -Simpl in H2. -Replace y with `y*1`. -Rewrite H2. -Assumption. - -Omega. -Save. - - -(* At last we come to the proof itself *************************************) - -(* we declare two variable x and y *) - -Global Variable x : Z ref. -Global Variable y : Z ref. - -(* and we give the annotated program *) - -Correctness factorielle - { `0 <= x` } - begin - y := 1; - while !x <> 0 do - { invariant `0 <= x` /\ (invariant y x x@0) as Inv - variant x for (Zwf ZERO) } - y := (Zmult !x !y); - x := (Zpred !x) - done - end - { (fact x@0 y) }. -Proof. -Split. -(* decreasing *) -Unfold Zwf. Unfold Zpred. Omega. -(* preservation of the invariant *) -Split. - Unfold Zpred; Omega. - Cut `0 < x0`. Intro Hx0. - Decompose [and] Inv. - Exact (fact_rec x x0 y1 Hx0 H0). - Omega. -(* entrance of the loop *) -Split; Auto. -Elim (fact_function x Pre1). Intros. -Apply c_inv with f:=x0 f0:=x0; Auto. -Omega. -(* exit of the loop *) -Decompose [and] Inv. -Rewrite H0 in H2. -Exact (invariant_0 x y1 H2). -Save. diff --git a/contrib/correctness/preuves.v b/contrib/correctness/preuves.v deleted file mode 100644 index 33659b43..00000000 --- a/contrib/correctness/preuves.v +++ /dev/null @@ -1,128 +0,0 @@ - -(* Quelques preuves sur des programmes simples, - * juste histoire d'avoir un petit bench. - *) - -Require Correctness. -Require Omega. - -Global Variable x : Z ref. -Global Variable y : Z ref. -Global Variable z : Z ref. -Global Variable i : Z ref. -Global Variable j : Z ref. -Global Variable n : Z ref. -Global Variable m : Z ref. -Variable r : Z. -Variable N : Z. -Global Variable t : array N of Z. - -(**********************************************************************) - -Require Exchange. -Require ArrayPermut. - -Correctness swap - fun (N:Z)(t:array N of Z)(i,j:Z) -> - { `0 <= i < N` /\ `0 <= j < N` } - (let v = t[i] in - begin - t[i] := t[j]; - t[j] := v - end) - { (exchange t t@ i j) }. -Proof. -Auto with datatypes. -Save. - -Correctness downheap - let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } = - (swap N t 0 0) { True } -. - -(**********************************************************************) - -Global Variable x : Z ref. -Debug on. -Correctness assign0 (x := 0) { `x=0` }. -Save. - -(**********************************************************************) - -Global Variable i : Z ref. -Debug on. -Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }. -Omega. -Save. - -(**********************************************************************) - -Global Variable i : Z ref. -Debug on. -Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }. -Omega. -Save. - -(**********************************************************************) - -Global Variable i : Z ref. -Debug on. -Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }. - -(**********************************************************************) - -Correctness echange - { `0 <= i < N` /\ `0 <= j < N` } - begin - label B; - x := t[!i]; t[!i] := t[!j]; t[!j] := !x; - assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] } - end. -Proof. -Auto with datatypes. -Save. - - -(**********************************************************************) - -(* - * while x <= y do x := x+1 done { y < x } - *) - -Correctness incrementation - while !x < !y do - { invariant True variant `(Zs y)-x` } - x := !x + 1 - done - { `y < x` }. -Proof. -Exact (Zwf_well_founded `0`). -Unfold Zwf. Omega. -Exact I. -Save. - - -(************************************************************************) - -Correctness pivot1 - begin - while (Z_lt_ge_dec !i r) do - { invariant True variant (Zminus (Zs r) i) } i := (Zs !i) - done; - while (Z_lt_ge_dec r !j) do - { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j) - done - end - { `j <= r` /\ `r <= i` }. -Proof. -Exact (Zwf_well_founded `0`). -Unfold Zwf. Omega. -Exact I. -Exact (Zwf_well_founded `0`). -Unfold Zwf. Unfold Zpred. Omega. -Exact I. -Omega. -Save. - - - diff --git a/contrib/dp/Dp.v b/contrib/dp/Dp.v deleted file mode 100644 index 857c182c..00000000 --- a/contrib/dp/Dp.v +++ /dev/null @@ -1,120 +0,0 @@ -(* Calls to external decision procedures *) - -Require Export ZArith. -Require Export Classical. - -(* Zenon *) - -(* Copyright 2004 INRIA *) -(* $Id: Dp.v 10739 2008-04-01 14:45:20Z herbelin $ *) - -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. - -(* Ergo *) - -Set Implicit Arguments. -Section congr. - Variable t:Type. -Lemma ergo_eq_concat_1 : - forall (P:t -> Prop) (x y:t), - P x -> x = y -> P y. -Proof. - intros; subst; auto. -Qed. - -Lemma ergo_eq_concat_2 : - forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), - P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. -Proof. - intros; subst; auto. -Qed. - -End congr. diff --git a/contrib/dp/TODO b/contrib/dp/TODO deleted file mode 100644 index 44349e21..00000000 --- a/contrib/dp/TODO +++ /dev/null @@ -1,24 +0,0 @@ - -TODO ----- - -- axiomes pour les prédicats récursifs comme - - Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - - ou encore In sur les listes du module Coq List. - -- discriminate - -- inversion (Set et Prop) - - -BUGS ----- - - diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml deleted file mode 100644 index d8803847..00000000 --- a/contrib/dp/dp.ml +++ /dev/null @@ -1,991 +0,0 @@ -(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) -(* Tactics to call decision procedures *) - -(* Works in two steps: - - - first the Coq context and the current goal are translated in - Polymorphic First-Order Logic (see fol.mli in this directory) - - - then the resulting query is passed to the Why tool that translates - it to the syntax of the selected prover (Simplify, CVC Lite, haRVey, - Zenon) -*) - -open Util -open Pp -open Libobject -open Summary -open Term -open Tacmach -open Tactics -open Tacticals -open Fol -open Names -open Nameops -open Termops -open Coqlib -open Hipattern -open Libnames -open Declarations -open Dp_why - -let debug = ref false -let set_debug b = debug := b -let trace = ref false -let set_trace b = trace := b -let timeout = ref 10 -let set_timeout n = timeout := n - -let (dp_timeout_obj,_) = - declare_object - {(default_object "Dp_timeout") with - cache_function = (fun (_,x) -> set_timeout x); - load_function = (fun _ (_,x) -> set_timeout x); - export_function = (fun x -> Some x)} - -let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) - -let (dp_debug_obj,_) = - declare_object - {(default_object "Dp_debug") with - cache_function = (fun (_,x) -> set_debug x); - load_function = (fun _ (_,x) -> set_debug x); - export_function = (fun x -> Some x)} - -let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) - -let (dp_trace_obj,_) = - declare_object - {(default_object "Dp_trace") with - cache_function = (fun (_,x) -> set_trace x); - load_function = (fun _ (_,x) -> set_trace x); - export_function = (fun x -> Some x)} - -let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x) - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ [["Coq"; "ZArith"; "BinInt"]] - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let constant = gen_constant_in_modules "dp" coq_modules - -let coq_Z = lazy (constant "Z") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") -let coq_Zminus = lazy (constant "Zminus") -let coq_Zdiv = lazy (constant "Zdiv") -let coq_Zs = lazy (constant "Zs") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Zge = lazy (constant "Zge") -let coq_Zlt = lazy (constant "Zlt") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_xH = lazy (constant "xH") -let coq_xI = lazy (constant "xI") -let coq_xO = lazy (constant "xO") -let coq_iff = lazy (constant "iff") - -(* not Prop typed expressions *) -exception NotProp - -(* not first-order expressions *) -exception NotFO - -(* Renaming of Coq globals *) - -let global_names = Hashtbl.create 97 -let used_names = Hashtbl.create 97 - -let rename_global r = - try - Hashtbl.find global_names r - with Not_found -> - let rec loop id = - if Hashtbl.mem used_names id then - loop (lift_ident id) - else begin - Hashtbl.add used_names id (); - let s = string_of_id id in - Hashtbl.add global_names r s; - s - end - in - loop (Nametab.id_of_global r) - -let foralls = - List.fold_right - (fun (x,t) p -> Forall (x, t, p)) - -let fresh_var = function - | Anonymous -> rename_global (VarRef (id_of_string "x")) - | Name x -> rename_global (VarRef x) - -(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of - env names, and returns the new variables together with the new - environment *) -let coq_rename_vars env vars = - let avoid = ref (ids_of_named_context (Environ.named_context env)) in - List.fold_right - (fun (na,t) (newvars, newenv) -> - let id = next_name_away na !avoid in - avoid := id :: !avoid; - id :: newvars, Environ.push_named (id, None, t) newenv) - vars ([],env) - -(* extract the prenex type quantifications i.e. - type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) -let decomp_type_quantifiers env t = - let rec loop vars t = match kind_of_term t with - | Prod (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -(* same thing with lambda binders (for axiomatize body) *) -let decomp_type_lambdas env t = - let rec loop vars t = match kind_of_term t with - | Lambda (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -let decompose_arrows = - let rec arrows_rec l c = match kind_of_term c with - | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c - | Cast (c,_,_) -> arrows_rec l c - | _ -> List.rev l, c - in - arrows_rec [] - -let rec eta_expanse t vars env i = - assert (i >= 0); - if i = 0 then - t, vars, env - else - match kind_of_term (Typing.type_of env Evd.empty t) with - | Prod (n, a, b) when not (dependent (mkRel 1) b) -> - let avoid = ids_of_named_context (Environ.named_context env) in - let id = next_name_away n avoid in - let env' = Environ.push_named (id, None, a) env in - let t' = mkApp (t, [| mkVar id |]) in - eta_expanse t' (id :: vars) env' (pred i) - | _ -> - assert false - -let rec skip_k_args k cl = match k, cl with - | 0, _ -> cl - | _, _ :: cl -> skip_k_args (k-1) cl - | _, [] -> raise NotFO - -(* Coq global references *) - -type global = Gnot_fo | Gfo of Fol.decl - -let globals = ref Refmap.empty -let globals_stack = ref [] - -(* synchronization *) -let () = - Summary.declare_summary "Dp globals" - { Summary.freeze_function = (fun () -> !globals, !globals_stack); - Summary.unfreeze_function = - (fun (g,s) -> globals := g; globals_stack := s); - Summary.init_function = (fun () -> ()); - Summary.survive_module = false; - Summary.survive_section = false } - -let add_global r d = globals := Refmap.add r d !globals -let mem_global r = Refmap.mem r !globals -let lookup_global r = match Refmap.find r !globals with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let locals = Hashtbl.create 97 - -let lookup_local r = match Hashtbl.find locals r with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let iter_all_constructors i f = - let _, oib = Global.lookup_inductive i in - Array.iteri - (fun j tj -> f j (mkConstruct (i, j+1))) - oib.mind_nf_lc - - -(* injection c [t1,...,tn] adds the injection axiom - forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. - c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) - -let injection c l = - let i = ref 0 in - let var s = incr i; id_of_string (s ^ string_of_int !i) in - let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in - i := 0; - let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in - let f = - List.fold_right2 - (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) - xl yl True - in - let vars = List.map (fun (x,_) -> App(x,[])) in - let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in - let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in - let f = foralls xl (foralls yl f) in - let ax = Axiom ("injection_" ^ c, f) in - globals_stack := ax :: !globals_stack - -(* rec_names_for c [|n1;...;nk|] builds the list of constant names for - identifiers n1...nk with the same path as c, if they exist; otherwise - raises Not_found *) -let rec_names_for c = - let mp,dp,_ = Names.repr_con c in - array_map_to_list - (function - | Name id -> - let c' = Names.make_con mp dp (label_of_id id) in - ignore (Global.lookup_constant c'); - msgnl (Printer.pr_constr (mkConst c')); - c' - | Anonymous -> - raise Not_found) - -(* abstraction tables *) - -let term_abstractions = Hashtbl.create 97 - -let new_abstraction = - let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r - -(* Arithmetic constants *) - -exception NotArithConstant - -(* translates a closed Coq term p:positive into a FOL term of type int *) -let rec tr_positive p = match kind_of_term p with - | Term.Construct _ when p = Lazy.force coq_xH -> - Cst 1 - | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> - Plus (Mult (Cst 2, tr_positive a), Cst 1) - | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> - Mult (Cst 2, tr_positive a) - | Term.Cast (p, _, _) -> - tr_positive p - | _ -> - raise NotArithConstant - -(* translates a closed Coq term t:Z into a FOL term of type int *) -let rec tr_arith_constant t = match kind_of_term t with - | Term.Construct _ when t = Lazy.force coq_Z0 -> - Cst 0 - | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> - tr_positive a - | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - Moins (Cst 0, tr_positive a) - | Term.Cast (t, _, _) -> - tr_arith_constant t - | _ -> - raise NotArithConstant - -(* translate a Coq term t:Set into a FOL type expression; - tv = list of type variables *) -and tr_type tv env t = - let t = Reductionops.nf_betadeltaiota env Evd.empty t in - if t = Lazy.force coq_Z then - Tid ("int", []) - else match kind_of_term t with - | Var x when List.mem x tv -> - Tvar (string_of_id x) - | _ -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclType (id, k) -> - assert (k = List.length cl); (* since t:Set *) - Tid (id, List.map (tr_type tv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> - (* we need to abstract some part of (f cl) *) - (*TODO*) - raise NotFO - end - -and make_term_abstraction tv env c = - let ty = Typing.type_of env Evd.empty c in - let id = new_abstraction () in - match tr_decl env id ty with - | DeclFun (id,_,_,_) as d -> - begin try - Hashtbl.find term_abstractions c - with Not_found -> - Hashtbl.add term_abstractions c id; - globals_stack := d :: !globals_stack; - id - end - | _ -> - raise NotFO - -(* translate a Coq declaration id:ty in a FOL declaration, that is either - - a type declaration : DeclType (id, n) where n:int is the type arity - - a function declaration : DeclFun (id, tl, t) ; that includes constants - - a predicate declaration : DeclPred (id, tl) - - an axiom : Axiom (id, p) - *) -and tr_decl env id ty = - let tv, env, t = decomp_type_quantifiers env ty in - if is_Set t || is_Type t then - DeclType (id, List.length tv) - else if is_Prop t then - DeclPred (id, List.length tv, []) - else - let s = Typing.type_of env Evd.empty t in - if is_Prop s then - Axiom (id, tr_formula tv [] env t) - else - let l, t = decompose_arrows t in - let l = List.map (tr_type tv env) l in - if is_Prop t then - DeclPred(id, List.length tv, l) - else - let s = Typing.type_of env Evd.empty t in - if is_Set s || is_Type s then - DeclFun (id, List.length tv, l, tr_type tv env t) - else - raise NotFO - -(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) -and tr_global env r = match r with - | VarRef id -> - lookup_local id - | r -> - try - lookup_global r - with Not_found -> - try - let ty = Global.type_of_global r in - let id = rename_global r in - let d = tr_decl env id ty in - (* r can be already declared if it is a constructor *) - if not (mem_global r) then begin - add_global r (Gfo d); - globals_stack := d :: !globals_stack - end; - begin try axiomatize_body env r id d with NotFO -> () end; - d - with NotFO -> - add_global r Gnot_fo; - raise NotFO - -and axiomatize_body env r id d = match r with - | VarRef _ -> - assert false - | ConstRef c -> - begin match (Global.lookup_constant c).const_body with - | Some b -> - let b = force b in - let axioms = - (match d with - | DeclPred (id, _, []) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_formula tv [] env b in - [id, Iff (Fatom (Pred (id, [])), value)] - | DeclFun (id, _, [], _) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_term tv [] env b in - [id, Fatom (Eq (Fol.App (id, []), value))] - | DeclFun (id, _, l, _) | DeclPred (id, _, l) -> - (*Format.eprintf "axiomatize_body %S@." id;*) - let b = match kind_of_term b with - (* a single recursive function *) - | Fix (_, (_,_,[|b|])) -> - subst1 (mkConst c) b - (* mutually recursive functions *) - | Fix ((_,i), (names,_,bodies)) -> - (* we only deal with named functions *) - begin try - let l = rec_names_for c names in - substl (List.rev_map mkConst l) bodies.(i) - with Not_found -> - b - end - | _ -> - b - in - let tv, env, b = decomp_type_lambdas env b in - let vars, t = decompose_lam b in - let n = List.length l in - let k = List.length vars in - assert (k <= n); - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - let t, vars, env = eta_expanse t vars env (n-k) in - let vars = List.rev vars in - let bv = vars in - let vars = List.map (fun x -> string_of_id x) vars in - let fol_var x = Fol.App (x, []) in - let fol_vars = List.map fol_var vars in - let vars = List.combine vars l in - begin match d with - | DeclFun (_, _, _, ty) -> - begin match kind_of_term t with - | Case (ci, _, e, br) -> - equations_for_case env id vars tv bv ci e br - | _ -> - let t = tr_term tv bv env t in - let ax = - add_proof (Fun_def (id, vars, ty, t)) - in - let p = Fatom (Eq (App (id, fol_vars), t)) in - [ax, foralls vars p] - end - | DeclPred _ -> - let value = tr_formula tv bv env t in - let p = Iff (Fatom (Pred (id, fol_vars)), value) in - [id, foralls vars p] - | _ -> - assert false - end - | DeclType _ -> - raise NotFO - | Axiom _ -> assert false) - in - let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in - globals_stack := axioms @ !globals_stack - | None -> - () (* Coq axiom *) - end - | IndRef i -> - iter_all_constructors i - (fun _ c -> - let rc = global_of_constr c in - try - begin match tr_global env rc with - | DeclFun (_, _, [], _) -> () - | DeclFun (idc, _, al, _) -> injection idc al - | _ -> () - end - with NotFO -> - ()) - | _ -> () - -and equations_for_case env id vars tv bv ci e br = match kind_of_term e with - | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars -> - let eqs = ref [] in - iter_all_constructors ci.ci_ind - (fun j cj -> - try - let cjr = global_of_constr cj in - begin match tr_global env cjr with - | DeclFun (idc, _, l, _) -> - let b = br.(j) in - let rec_vars, b = decompose_lam b in - let rec_vars, env = coq_rename_vars env rec_vars in - let coq_rec_vars = List.map mkVar rec_vars in - let b = substl coq_rec_vars b in - let rec_vars = List.rev rec_vars in - let coq_rec_term = applist (cj, List.rev coq_rec_vars) in - let b = replace_vars [x, coq_rec_term] b in - let bv = bv @ rec_vars in - let rec_vars = List.map string_of_id rec_vars in - let fol_var x = Fol.App (x, []) in - let fol_rec_vars = List.map fol_var rec_vars in - let fol_rec_term = App (idc, fol_rec_vars) in - let rec_vars = List.combine rec_vars l in - let fol_vars = List.map fst vars in - let fol_vars = List.map fol_var fol_vars in - let fol_vars = List.map (fun y -> match y with - | App (id, _) -> - if id = string_of_id x - then fol_rec_term - else y - | _ -> y) - fol_vars in - let vars = vars @ rec_vars in - let rec remove l e = match l with - | [] -> [] - | (y, t)::l' -> if y = string_of_id e then l' - else (y, t)::(remove l' e) in - let vars = remove vars x in - let p = - Fatom (Eq (App (id, fol_vars), - tr_term tv bv env b)) - in - eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs - | _ -> - assert false end - with NotFO -> - ()); - !eqs - | _ -> - raise NotFO - -(* assumption: t:T:Set *) -and tr_term tv bv env t = match kind_of_term t with - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> - Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> - Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> - Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> - Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.Var id when List.mem id bv -> - App (string_of_id id, []) - | _ -> - try - tr_arith_constant t - with NotArithConstant -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclFun (s, k, _, _) -> - let cl = skip_k_args k cl in - Fol.App (s, List.map (tr_term tv bv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> (* we need to abstract some part of (f cl) *) - let rec abstract app = function - | [] -> - Fol.App (make_term_abstraction tv env app, []) - | x :: l as args -> - begin try - let s = make_term_abstraction tv env app in - Fol.App (s, List.map (tr_term tv bv env) args) - with NotFO -> - abstract (applist (app, [x])) l - end - in - let app,l = match cl with - | x :: l -> applist (f, [x]), l | [] -> raise NotFO - in - abstract app l - end - -and quantifiers n a b tv bv env = - let vars, env = coq_rename_vars env [n,a] in - let id = match vars with [x] -> x | _ -> assert false in - let b = subst1 (mkVar id) b in - let t = tr_type tv env a in - let bv = id :: bv in - id, t, bv, env, b - -(* assumption: f is of type Prop *) -and tr_formula tv bv env f = - let c, args = decompose_app f in - match kind_of_term c, args with - | Var id, [] -> - Fatom (Pred (rename_global (VarRef id), [])) - | _, [t;a;b] when c = build_coq_eq () -> - let ty = Typing.type_of env Evd.empty t in - if is_Set ty || is_Type ty then - let _ = tr_type tv env t in - Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) - else - raise NotFO - | _, [a;b] when c = Lazy.force coq_Zle -> - Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zlt -> - Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zge -> - Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zgt -> - Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [] when c = build_coq_False () -> - False - | _, [] when c = build_coq_True () -> - True - | _, [a] when c = build_coq_not () -> - Not (tr_formula tv bv env a) - | _, [a;b] when c = build_coq_and () -> - And (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = build_coq_or () -> - Or (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = Lazy.force coq_iff -> - Iff (tr_formula tv bv env a, tr_formula tv bv env b) - | Prod (n, a, b), _ -> - if is_imp_term f then - Imp (tr_formula tv bv env a, tr_formula tv bv env b) - else - let id, t, bv, env, b = quantifiers n a b tv bv env in - Forall (string_of_id id, t, tr_formula tv bv env b) - | _, [_; a] when c = build_coq_ex () -> - begin match kind_of_term a with - | Lambda(n, a, b) -> - let id, t, bv, env, b = quantifiers n a b tv bv env in - Exists (string_of_id id, t, tr_formula tv bv env b) - | _ -> - (* unusual case of the shape (ex p) *) - raise NotFO (* TODO: we could eta-expanse *) - end - | _ -> - begin try - let r = global_of_constr c in - match tr_global env r with - | DeclPred (s, k, _) -> - let args = skip_k_args k args in - Fatom (Pred (s, List.map (tr_term tv bv env) args)) - | _ -> - raise NotFO - with Not_found -> - raise NotFO - end - - -let tr_goal gl = - Hashtbl.clear locals; - let tr_one_hyp (id, ty) = - try - let s = rename_global (VarRef id) in - let d = tr_decl (pf_env gl) s ty in - Hashtbl.add locals id (Gfo d); - d - with NotFO -> - Hashtbl.add locals id Gnot_fo; - raise NotFO - in - let hyps = - List.fold_right - (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) - (pf_hyps_types gl) [] - in - let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in - let hyps = List.rev_append !globals_stack (List.rev hyps) in - hyps, c - - -type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy - -let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) - -let sprintf = Format.sprintf - -let file_contents f = - let buf = Buffer.create 1024 in - try - let c = open_in f in - begin try - while true do - let s = input_line c in Buffer.add_string buf s; - Buffer.add_char buf '\n' - done; - assert false - with End_of_file -> - close_in c; - Buffer.contents buf - end - with _ -> - sprintf "(cannot open %s)" f - -let timeout_sys_command cmd = - if !debug then Format.eprintf "command line: %s@." cmd; - let out = Filename.temp_file "out" "" in - let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in - let ret = Sys.command cmd in - if !debug then - Format.eprintf "Output file %s:@.%s@." out (file_contents out); - ret, out - -let timeout_or_failure c cmd out = - if c = 152 then - Timeout - else - Failure - (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) - -let prelude_files = ref ([] : string list) - -let set_prelude l = prelude_files := l - -let (dp_prelude_obj,_) = - declare_object - {(default_object "Dp_prelude") with - cache_function = (fun (_,x) -> set_prelude x); - load_function = (fun _ (_,x) -> set_prelude x); - export_function = (fun x -> Some x)} - -let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) - -let why_files f = String.concat " " (!prelude_files @ [f]) - -let call_simplify fwhy = - let cmd = - sprintf "why --simplify %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in - let cmd = - sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" - !timeout fsx - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsx]; - r - -let call_ergo fwhy = - let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in - let ftrace = Filename.temp_file "ergo_trace" "" in - let cmd = - if !trace then - sprintf "ergo -cctrace %s %s" ftrace fwhy - else - sprintf "ergo %s" fwhy - in - let ret,out = timeout_sys_command cmd in - let r = - if ret <> 0 then - timeout_or_failure ret cmd out - else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then - Valid (if !trace then Some ftrace else None) - else if Sys.command (sprintf "grep -q -w \"I don't know\" %s" out) = 0 then - DontKnow - else if Sys.command (sprintf "grep -q -w \"Invalid\" %s" out) = 0 then - Invalid - else - Failure ("command failed: " ^ cmd) - in - if not !debug then remove_files [fwhy; out]; - r - -let call_zenon fwhy = - let cmd = - sprintf "why --no-prelude --no-zenon-prelude --zenon %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in - let out = Filename.temp_file "dp_out" "" in - let cmd = - sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out - in - let c = Sys.command cmd in - if not !debug then remove_files [fwhy; fznn]; - if c = 137 then - Timeout - else begin - if c <> 0 then anomaly ("command failed: " ^ cmd); - if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then - error "Zenon failed"; - let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in - if c = 0 then Valid (Some out) else Invalid - end - -let call_yices fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" - !timeout fsmt - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsmt]; - r - -let call_cvcl fwhy = - let cmd = - sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in - let cmd = - sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" - !timeout fcvc - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fcvc]; - r - -let call_harvey fwhy = - let cmd = - sprintf "why --harvey --encoding strat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in - let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in - if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); - let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in - let outf = Filename.temp_file "rv" ".out" in - let out = - Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" - !timeout f outf) - in - let r = - if out <> 0 then - Timeout - else - let cmd = - sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf - in - if Sys.command cmd = 0 then Valid None else Invalid - in - if not !debug then remove_files [fwhy; frv; outf]; - r - -let call_gwhy fwhy = - let cmd = sprintf "gwhy %s" (why_files fwhy) in - if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy)); - NoAnswer - -let ergo_proof_from_file f gl = - let s = - let buf = Buffer.create 1024 in - let c = open_in f in - try - while true do Buffer.add_string buf (input_line c) done; assert false - with End_of_file -> - close_in c; - Buffer.contents buf - in - let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in - let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in - exact_check t gl - -let call_prover prover q = - let fwhy = Filename.temp_file "coq_dp" ".why" in - Dp_why.output_file fwhy q; - match prover with - | Simplify -> call_simplify fwhy - | Ergo -> call_ergo fwhy - | Yices -> call_yices fwhy - | Zenon -> call_zenon fwhy - | CVCLite -> call_cvcl fwhy - | Harvey -> call_harvey fwhy - | Gwhy -> call_gwhy fwhy - -let dp prover gl = - Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; - let concl_type = pf_type_of gl (pf_concl gl) in - if not (is_Prop concl_type) then error "Conclusion is not a Prop"; - try - let q = tr_goal gl in - begin match call_prover prover q with - | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl - | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl - | Valid _ -> Tactics.admit_as_an_axiom gl - | Invalid -> error "Invalid" - | DontKnow -> error "Don't know" - | Timeout -> error "Timeout" - | Failure s -> error s - | NoAnswer -> Tacticals.tclIDTAC gl - end - with NotFO -> - error "Not a first order goal" - - -let simplify = tclTHEN intros (dp Simplify) -let ergo = tclTHEN intros (dp Ergo) -let yices = tclTHEN intros (dp Yices) -let cvc_lite = tclTHEN intros (dp CVCLite) -let harvey = dp Harvey -let zenon = tclTHEN intros (dp Zenon) -let gwhy = tclTHEN intros (dp Gwhy) - -let dp_hint l = - let env = Global.env () in - let one_hint (qid,r) = - if not (mem_global r) then begin - let ty = Global.type_of_global r in - let s = Typing.type_of env Evd.empty ty in - if is_Prop s then - try - let id = rename_global r in - let tv, env, ty = decomp_type_quantifiers env ty in - let d = Axiom (id, tr_formula tv [] env ty) in - add_global r (Gfo d); - globals_stack := d :: !globals_stack - with NotFO -> - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ - str " ignored (not a first order proposition)") - else begin - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ str " ignored (not a proposition)") - end - end - in - List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) - -let (dp_hint_obj,_) = - declare_object - {(default_object "Dp_hint") with - cache_function = (fun (_,l) -> dp_hint l); - load_function = (fun _ (_,l) -> dp_hint l); - export_function = (fun x -> Some x)} - -let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l) - -let dp_predefined qid s = - let r = Nametab.global qid in - let ty = Global.type_of_global r in - let env = Global.env () in - let id = rename_global r in - try - let d = match tr_decl env id ty with - | DeclType (_, n) -> DeclType (s, n) - | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) - | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) - | Axiom _ as d -> d - in - match d with - | Axiom _ -> msg_warning (str " ignored (axiom)") - | d -> add_global r (Gfo d) - with NotFO -> - msg_warning (str " ignored (not a first order declaration)") - -let (dp_predefined_obj,_) = - declare_object - {(default_object "Dp_predefined") with - cache_function = (fun (_,(id,s)) -> dp_predefined id s); - load_function = (fun _ (_,(id,s)) -> dp_predefined id s); - export_function = (fun x -> Some x)} - -let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) - -let _ = declare_summary "Dp options" - { freeze_function = - (fun () -> !debug, !trace, !timeout, !prelude_files); - unfreeze_function = - (fun (d,tr,tm,pr) -> - debug := d; trace := tr; timeout := tm; prelude_files := pr); - init_function = - (fun () -> - debug := false; trace := false; timeout := 10; - prelude_files := []); - survive_module = true; - survive_section = true } diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli deleted file mode 100644 index 6dbc05e1..00000000 --- a/contrib/dp/dp.mli +++ /dev/null @@ -1,20 +0,0 @@ - -open Libnames -open Proof_type - -val simplify : tactic -val ergo : tactic -val yices : tactic -val cvc_lite : tactic -val harvey : tactic -val zenon : tactic -val gwhy : tactic - -val dp_hint : reference list -> unit -val dp_timeout : int -> unit -val dp_debug : bool -> unit -val dp_trace : bool -> unit -val dp_prelude : string list -> unit -val dp_predefined : reference -> string -> unit - - diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml deleted file mode 100644 index 9c035aa8..00000000 --- a/contrib/dp/dp_gappa.ml +++ /dev/null @@ -1,445 +0,0 @@ - -open Format -open Util -open Pp -open Term -open Tacmach -open Tactics -open Tacticals -open Names -open Nameops -open Termops -open Coqlib -open Hipattern -open Libnames -open Declarations -open Evarutil - -let debug = ref false - -(* 1. gappa syntax trees and output *) - -module Constant = struct - - open Bigint - - type t = { mantissa : bigint; base : int; exp : bigint } - - let create (b, m, e) = - { mantissa = m; base = b; exp = e } - - let of_int x = - { mantissa = x; base = 1; exp = zero } - - let print fmt x = match x.base with - | 1 -> fprintf fmt "%s" (to_string x.mantissa) - | 2 -> fprintf fmt "%sb%s" (to_string x.mantissa) (to_string x.exp) - | 10 -> fprintf fmt "%se%s" (to_string x.mantissa) (to_string x.exp) - | _ -> assert false - -end - -type binop = Bminus | Bplus | Bmult | Bdiv - -type unop = Usqrt | Uabs | Uopp - -type rounding_mode = string - -type term = - | Tconst of Constant.t - | Tvar of string - | Tbinop of binop * term * term - | Tunop of unop * term - | Tround of rounding_mode * term - -type pred = - | Pin of term * Constant.t * Constant.t - -let rec print_term fmt = function - | Tconst c -> Constant.print fmt c - | Tvar s -> pp_print_string fmt s - | Tbinop (op, t1, t2) -> - let op = match op with - | Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/" - in - fprintf fmt "(%a %s %a)" print_term t1 op print_term t2 - | Tunop (Uabs, t) -> - fprintf fmt "|%a|" print_term t - | Tunop (Uopp | Usqrt as op, t) -> - let s = match op with - | Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false - in - fprintf fmt "(%s(%a))" s print_term t - | Tround (m, t) -> - fprintf fmt "(%s(%a))" m print_term t - -let print_pred fmt = function - | Pin (t, c1, c2) -> - fprintf fmt "%a in [%a, %a]" - print_term t Constant.print c1 Constant.print c2 - -let temp_file f = if !debug then f else Filename.temp_file f ".v" -let remove_file f = if not !debug then try Sys.remove f with _ -> () - -let read_gappa_proof f = - let buf = Buffer.create 1024 in - Buffer.add_char buf '('; - let cin = open_in f in - let rec skip_space () = - let c = input_char cin in if c = ' ' then skip_space () else c - in - while input_char cin <> '=' do () done; - try - while true do - let c = skip_space () in - if c = ':' then raise Exit; - Buffer.add_char buf c; - let s = input_line cin in - Buffer.add_string buf s; - Buffer.add_char buf '\n'; - done; - assert false - with Exit -> - close_in cin; - remove_file f; - Buffer.add_char buf ')'; - Buffer.contents buf - -exception GappaFailed -exception GappaProofFailed - -let patch_gappa_proof fin fout = - let cin = open_in fin in - let cout = open_out fout in - let fmt = formatter_of_out_channel cout in - let last = ref "" in - let defs = ref "" in - try - while true do - let s = input_line cin in - if s = "Qed." then - fprintf fmt "Defined.@\n" - else begin - begin - try Scanf.sscanf s "Lemma %s " - (fun n -> defs := n ^ " " ^ !defs; last := n) - with Scanf.Scan_failure _ -> - try Scanf.sscanf s "Definition %s " - (fun n -> defs := n ^ " " ^ !defs) - with Scanf.Scan_failure _ -> - () - end; - fprintf fmt "%s@\n" s - end - done - with End_of_file -> - close_in cin; - fprintf fmt "Definition proof := Eval cbv delta [%s] in %s.@." !defs !last; - close_out cout - -let call_gappa hl p = - let gappa_in = temp_file "gappa_input" in - let c = open_out gappa_in in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[{ "; - List.iter (fun h -> fprintf fmt "%a ->@ " print_pred h) hl; - fprintf fmt "%a }@]@." print_pred p; - close_out c; - let gappa_out = temp_file "gappa_output" in - let cmd = sprintf "gappa -Bcoq < %s > %s 2> /dev/null" gappa_in gappa_out in - let out = Sys.command cmd in - if out <> 0 then raise GappaFailed; - remove_file gappa_in; - let gappa_out2 = temp_file "gappa2" in - patch_gappa_proof gappa_out gappa_out2; - remove_file gappa_out; - let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out2 in - let out = Sys.command cmd in - if out <> 0 then raise GappaProofFailed; - let gappa_out3 = temp_file "gappa3" in - let c = open_out gappa_out3 in - let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in - Printf.fprintf c - "Require \"%s\". Set Printing Depth 999999. Print %s.proof." - (Filename.chop_suffix gappa_out2 ".v") gappa2; - close_out c; - let lambda = temp_file "gappa_lambda" in - let cmd = (Filename.concat (Envars.coqbin ()) "coqc") ^ " " ^ gappa_out3 ^ " > " ^ lambda in - let out = Sys.command cmd in - if out <> 0 then raise GappaProofFailed; - remove_file gappa_out2; remove_file gappa_out3; - remove_file (gappa_out2 ^ "o"); remove_file (gappa_out3 ^ "o"); - read_gappa_proof lambda - -(* 2. coq -> gappa translation *) - -exception NotGappa - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ [["Coq"; "ZArith"; "BinInt"]; - ["Coq"; "Reals"; "Rdefinitions"]; - ["Coq"; "Reals"; "Raxioms";]; - ["Coq"; "Reals"; "Rbasic_fun";]; - ["Coq"; "Reals"; "R_sqrt";]; - ["Coq"; "Reals"; "Rfunctions";]; - ["Gappa"; "Gappa_tactic";]; - ["Gappa"; "Gappa_fixed";]; - ["Gappa"; "Gappa_float";]; - ["Gappa"; "Gappa_round_def";]; - ["Gappa"; "Gappa_pred_bnd";]; - ["Gappa"; "Gappa_definitions";]; - ] - -let constant = gen_constant_in_modules "gappa" coq_modules - -let coq_refl_equal = lazy (constant "refl_equal") -let coq_Rle = lazy (constant "Rle") -let coq_R = lazy (constant "R") -(* -let coq_Rplus = lazy (constant "Rplus") -let coq_Rminus = lazy (constant "Rminus") -let coq_Rmult = lazy (constant "Rmult") -let coq_Rdiv = lazy (constant "Rdiv") -let coq_powerRZ = lazy (constant "powerRZ") -let coq_R1 = lazy (constant "R1") -let coq_Ropp = lazy (constant "Ropp") -let coq_Rabs = lazy (constant "Rabs") -let coq_sqrt = lazy (constant "sqrt") -*) - -let coq_convert = lazy (constant "convert") -let coq_reUnknown = lazy (constant "reUnknown") -let coq_reFloat2 = lazy (constant "reFloat2") -let coq_reFloat10 = lazy (constant "reFloat10") -let coq_reInteger = lazy (constant "reInteger") -let coq_reBinary = lazy (constant "reBinary") -let coq_reUnary = lazy (constant "reUnary") -let coq_reRound = lazy (constant "reRound") -let coq_roundDN = lazy (constant "roundDN") -let coq_roundUP = lazy (constant "roundUP") -let coq_roundNE = lazy (constant "roundNE") -let coq_roundZR = lazy (constant "roundZR") -let coq_rounding_fixed = lazy (constant "rounding_fixed") -let coq_rounding_float = lazy (constant "rounding_float") -let coq_boAdd = lazy (constant "boAdd") -let coq_boSub = lazy (constant "boSub") -let coq_boMul = lazy (constant "boMul") -let coq_boDiv = lazy (constant "boDiv") -let coq_uoAbs = lazy (constant "uoAbs") -let coq_uoNeg = lazy (constant "uoNeg") -let coq_uoSqrt = lazy (constant "uoSqrt") -let coq_subset = lazy (constant "subset") -let coq_makepairF = lazy (constant "makepairF") - -let coq_true = lazy (constant "true") -let coq_false = lazy (constant "false") - -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_xH = lazy (constant "xH") -let coq_xI = lazy (constant "xI") -let coq_xO = lazy (constant "xO") -let coq_IZR = lazy (constant "IZR") - -(* translates a closed Coq term p:positive into a FOL term of type int *) -let rec tr_positive p = match kind_of_term p with - | Term.Construct _ when p = Lazy.force coq_xH -> - 1 - | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> - 2 * (tr_positive a) + 1 - | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> - 2 * (tr_positive a) - | Term.Cast (p, _, _) -> - tr_positive p - | _ -> - raise NotGappa - -(* translates a closed Coq term t:Z into a term of type int *) -let rec tr_arith_constant t = match kind_of_term t with - | Term.Construct _ when t = Lazy.force coq_Z0 -> 0 - | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_positive a - | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - (tr_positive a) - | Term.Cast (t, _, _) -> tr_arith_constant t - | _ -> raise NotGappa - -(* translates a closed Coq term p:positive into a FOL term of type bigint *) -let rec tr_bigpositive p = match kind_of_term p with - | Term.Construct _ when p = Lazy.force coq_xH -> - Bigint.one - | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> - Bigint.add_1 (Bigint.mult_2 (tr_bigpositive a)) - | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> - (Bigint.mult_2 (tr_bigpositive a)) - | Term.Cast (p, _, _) -> - tr_bigpositive p - | _ -> - raise NotGappa - -(* translates a closed Coq term t:Z into a term of type bigint *) -let rec tr_arith_bigconstant t = match kind_of_term t with - | Term.Construct _ when t = Lazy.force coq_Z0 -> Bigint.zero - | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_bigpositive a - | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - Bigint.neg (tr_bigpositive a) - | Term.Cast (t, _, _) -> tr_arith_bigconstant t - | _ -> raise NotGappa - -let decomp c = - let c, args = decompose_app c in - kind_of_term c, args - -let tr_bool c = match decompose_app c with - | c, [] when c = Lazy.force coq_true -> true - | c, [] when c = Lazy.force coq_false -> false - | _ -> raise NotGappa - -let tr_float b m e = - (b, tr_arith_bigconstant m, tr_arith_bigconstant e) - -let tr_binop c = match decompose_app c with - | c, [] when c = Lazy.force coq_boAdd -> Bplus - | c, [] when c = Lazy.force coq_boSub -> Bminus - | c, [] when c = Lazy.force coq_boMul -> Bmult - | c, [] when c = Lazy.force coq_boDiv -> Bdiv - | _ -> assert false - -let tr_unop c = match decompose_app c with - | c, [] when c = Lazy.force coq_uoNeg -> Uopp - | c, [] when c = Lazy.force coq_uoSqrt -> Usqrt - | c, [] when c = Lazy.force coq_uoAbs -> Uabs - | _ -> raise NotGappa - -let tr_var c = match decomp c with - | Var x, [] -> string_of_id x - | _ -> assert false - -let tr_mode c = match decompose_app c with - | c, [] when c = Lazy.force coq_roundDN -> "dn" - | c, [] when c = Lazy.force coq_roundNE -> "ne" - | c, [] when c = Lazy.force coq_roundUP -> "up" - | c, [] when c = Lazy.force coq_roundZR -> "zr" - | _ -> raise NotGappa - -let tr_rounding_mode c = match decompose_app c with - | c, [a;b] when c = Lazy.force coq_rounding_fixed -> - let a = tr_mode a in - let b = tr_arith_constant b in - sprintf "fixed<%d,%s>" b a - | c, [a;p;e] when c = Lazy.force coq_rounding_float -> - let a = tr_mode a in - let p = tr_positive p in - let e = tr_arith_constant e in - sprintf "float<%d,%d,%s>" p (-e) a - | _ -> - raise NotGappa - -(* REexpr -> term *) -let rec tr_term c0 = - let c, args = decompose_app c0 in - match kind_of_term c, args with - | _, [a] when c = Lazy.force coq_reUnknown -> - Tvar (tr_var a) - | _, [a; b] when c = Lazy.force coq_reFloat2 -> - Tconst (Constant.create (tr_float 2 a b)) - | _, [a; b] when c = Lazy.force coq_reFloat10 -> - Tconst (Constant.create (tr_float 10 a b)) - | _, [a] when c = Lazy.force coq_reInteger -> - Tconst (Constant.create (1, tr_arith_bigconstant a, Bigint.zero)) - | _, [op;a;b] when c = Lazy.force coq_reBinary -> - Tbinop (tr_binop op, tr_term a, tr_term b) - | _, [op;a] when c = Lazy.force coq_reUnary -> - Tunop (tr_unop op, tr_term a) - | _, [op;a] when c = Lazy.force coq_reRound -> - Tround (tr_rounding_mode op, tr_term a) - | _ -> - msgnl (str "tr_term: " ++ Printer.pr_constr c0); - assert false - -let tr_rle c = - let c, args = decompose_app c in - match kind_of_term c, args with - | _, [a;b] when c = Lazy.force coq_Rle -> - begin match decompose_app a, decompose_app b with - | (ac, [at]), (bc, [bt]) - when ac = Lazy.force coq_convert && bc = Lazy.force coq_convert -> - at, bt - | _ -> - raise NotGappa - end - | _ -> - raise NotGappa - -let tr_pred c = - let c, args = decompose_app c in - match kind_of_term c, args with - | _, [a;b] when c = build_coq_and () -> - begin match tr_rle a, tr_rle b with - | (c1, t1), (t2, c2) when t1 = t2 -> - begin match tr_term c1, tr_term c2 with - | Tconst c1, Tconst c2 -> - Pin (tr_term t1, c1, c2) - | _ -> - raise NotGappa - end - | _ -> - raise NotGappa - end - | _ -> - raise NotGappa - -let is_R c = match decompose_app c with - | c, [] when c = Lazy.force coq_R -> true - | _ -> false - -let tr_hyps = - List.fold_left - (fun acc (_,h) -> try tr_pred h :: acc with NotGappa -> acc) [] - -let constr_of_string gl s = - let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in - Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) - -let var_name = function - | Name id -> - let s = string_of_id id in - let s = String.sub s 1 (String.length s - 1) in - mkVar (id_of_string s) - | Anonymous -> - assert false - -let build_proof_term c0 = - let bl,c = decompose_lam c0 in - List.fold_right - (fun (x,t) pf -> - mkApp (pf, [| if is_R t then var_name x else mk_new_meta () |])) - bl c0 - -let gappa_internal gl = - try - let c = tr_pred (pf_concl gl) in - let s = call_gappa (tr_hyps (pf_hyps_types gl)) c in - let pf = constr_of_string gl s in - let pf = build_proof_term pf in - Tacticals.tclTHEN (Tacmach.refine_no_check pf) Tactics.assumption gl - with - | NotGappa -> error "not a gappa goal" - | GappaFailed -> error "gappa failed" - | GappaProofFailed -> error "incorrect gappa proof term" - -let gappa_prepare = - let id = Ident (dummy_loc, id_of_string "gappa_prepare") in - lazy (Tacinterp.interp (Tacexpr.TacArg (Tacexpr.Reference id))) - -let gappa gl = - Coqlib.check_required_library ["Gappa"; "Gappa_tactic"]; - Tacticals.tclTHEN (Lazy.force gappa_prepare) gappa_internal gl - -(* -Local Variables: -compile-command: "make -C ../.. bin/coqc.opt bin/coqide.opt" -End: -*) - diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml deleted file mode 100644 index e24049ad..00000000 --- a/contrib/dp/dp_why.ml +++ /dev/null @@ -1,151 +0,0 @@ - -(* Pretty-print PFOL (see fol.mli) in Why syntax *) - -open Format -open Fol - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -let proofs = Hashtbl.create 97 -let proof_name = - let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r - -let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n - -let find_proof = Hashtbl.find proofs - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " -let comma fmt () = fprintf fmt ",@ " - -let is_why_keyword = - let h = Hashtbl.create 17 in - List.iter - (fun s -> Hashtbl.add h s ()) - ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; - "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; - "external"; "false"; "for"; "forall"; "fun"; "function"; "goal"; - "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; - "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; - "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; - "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; - Hashtbl.mem h - -let ident fmt s = - if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s - -let rec print_typ fmt = function - | Tvar x -> fprintf fmt "'%a" ident x - | Tid ("int", []) -> fprintf fmt "int" - | Tid (x, []) -> fprintf fmt "%a" ident x - | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x - | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%d" n - | Plus (a, b) -> - fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b - | App (id, []) -> - fprintf fmt "%a" ident id - | App (id, tl) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - -and print_terms fmt tl = - print_list comma print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "true" - | False -> - fprintf fmt "false" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b - | Fatom (Pred (id, [])) -> - fprintf fmt "%a" ident id - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(%a ->@ %a)@]" pp a pp b - | Iff (a, b) -> - fprintf fmt "@[(%a <->@ %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(%a and@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(%a or@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(not@ %a)@]" pp a - | Forall (id, t, p) -> - fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p - | Exists (id, t, p) -> - fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p - -let print_query fmt (decls,concl) = - let print_dtype = function - | DeclType (id, 0) -> - fprintf fmt "@[type %a@]@\n@\n" ident id - | DeclType (id, 1) -> - fprintf fmt "@[type 'a %a@]@\n@\n" ident id - | DeclType (id, n) -> - fprintf fmt "@[type ("; - for i = 1 to n do - fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " - done; - fprintf fmt ") %a@]@\n@\n" ident id - | DeclFun _ | DeclPred _ | Axiom _ -> - () - in - let print_dvar_dpred = function - | DeclFun (id, _, [], t) -> - fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t - | DeclFun (id, _, l, t) -> - fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" - ident id (print_list comma print_typ) l print_typ t - | DeclPred (id, _, []) -> - fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id - | DeclPred (id, _, l) -> - fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" - ident id (print_list comma print_typ) l - | DeclType _ | Axiom _ -> - () - in - let print_assert = function - | Axiom (id, f) -> - fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f - | DeclType _ | DeclFun _ | DeclPred _ -> - () - in - List.iter print_dtype decls; - List.iter print_dvar_dpred decls; - List.iter print_assert decls; - fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl - -let output_file f q = - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c - - diff --git a/contrib/dp/dp_why.mli b/contrib/dp/dp_why.mli deleted file mode 100644 index b38a3d37..00000000 --- a/contrib/dp/dp_why.mli +++ /dev/null @@ -1,17 +0,0 @@ - -open Fol - -(* generation of the Why file *) - -val output_file : string -> query -> unit - -(* table to translate the proofs back to Coq (used in dp_zenon) *) - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -val add_proof : proof -> string -val find_proof : string -> proof - - diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli deleted file mode 100644 index 0a727d1f..00000000 --- a/contrib/dp/dp_zenon.mli +++ /dev/null @@ -1,7 +0,0 @@ - -open Fol - -val set_debug : bool -> unit - -val proof_from_file : string -> Proof_type.tactic - diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll deleted file mode 100644 index e15e280d..00000000 --- a/contrib/dp/dp_zenon.mll +++ /dev/null @@ -1,181 +0,0 @@ - -{ - - open Lexing - open Pp - open Util - open Names - open Tacmach - open Dp_why - open Tactics - open Tacticals - - let debug = ref false - let set_debug b = debug := b - - let buf = Buffer.create 1024 - - let string_of_global env ref = - Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) - - let axioms = ref [] - - (* we cannot interpret the terms as we read them (since some lemmas - may need other lemmas to be already interpreted) *) - type lemma = { l_id : string; l_type : string; l_proof : string } - type zenon_proof = lemma list * string - -} - -let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+ -let space = [' ' '\t' '\r'] - -rule start = parse -| "(* BEGIN-PROOF *)" "\n" { scan lexbuf } -| _ { start lexbuf } -| eof { anomaly "malformed Zenon proof term" } - -(* here we read the lemmas and the main proof term; - meanwhile we maintain the set of axioms that were used *) - -and scan = parse -| "Let" space (ident as id) space* ":" - { let t = read_coq_term lexbuf in - let p = read_lemma_proof lexbuf in - let l,pr = scan lexbuf in - { l_id = id; l_type = t; l_proof = p } :: l, pr } -| "Definition theorem:" - { let t = read_main_proof lexbuf in [], t } -| _ | eof - { anomaly "malformed Zenon proof term" } - -and read_coq_term = parse -| "." "\n" - { let s = Buffer.contents buf in Buffer.clear buf; s } -| "coq__" (ident as id) (* a Why keyword renamed *) - { Buffer.add_string buf id; read_coq_term lexbuf } -| ("dp_axiom__" ['0'-'9']+) as id - { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } -| _ as c - { Buffer.add_char buf c; read_coq_term lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - -and read_lemma_proof = parse -| "Proof" space - { read_coq_term lexbuf } -| _ | eof - { anomaly "malformed Zenon proof term" } - -(* skip the main proof statement and then read its term *) -and read_main_proof = parse -| ":=" "\n" - { read_coq_term lexbuf } -| _ - { read_main_proof lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - - -{ - - let read_zenon_proof f = - Buffer.clear buf; - let c = open_in f in - let lb = from_channel c in - let p = start lb in - close_in c; - if not !debug then begin try Sys.remove f with _ -> () end; - p - - let constr_of_string gl s = - let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in - Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) - - (* we are lazy here: we build strings containing Coq terms using a *) - (* pretty-printer Fol -> Coq *) - module Coq = struct - open Format - open Fol - - let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - - let space fmt () = fprintf fmt "@ " - let comma fmt () = fprintf fmt ",@ " - - let rec print_typ fmt = function - | Tvar x -> fprintf fmt "%s" x - | Tid ("int", []) -> fprintf fmt "Z" - | Tid (x, []) -> fprintf fmt "%s" x - | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t - | Tid (x,tl) -> - fprintf fmt "(%s %a)" x (print_list comma print_typ) tl - - let rec print_term fmt = function - | Cst n -> - fprintf fmt "%d" n - | Plus (a, b) -> - fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b - | App (id, []) -> - fprintf fmt "%s" id - | App (id, tl) -> - fprintf fmt "@[(%s %a)@]" id print_terms tl - - and print_terms fmt tl = - print_list space print_term fmt tl - - (* builds the text for "forall vars, f vars = t" *) - let fun_def_axiom f vars t = - let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in - fprintf str_formatter - "@[(forall %a, %s %a = %a)@]@." - (print_list space binder) vars f - (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars - print_term t; - flush_str_formatter () - - end - - let prove_axiom id = match Dp_why.find_proof id with - | Immediate t -> - exact_check t - | Fun_def (f, vars, ty, t) -> - tclTHENS - (fun gl -> - let s = Coq.fun_def_axiom f vars t in - if !debug then Format.eprintf "axiom fun def = %s@." s; - let c = constr_of_string gl s in - assert_tac (Name (id_of_string id)) c gl) - [tclTHEN intros reflexivity; tclIDTAC] - - let exact_string s gl = - let c = constr_of_string gl s in - exact_check c gl - - let interp_zenon_proof (ll,p) = - let interp_lemma l gl = - let ty = constr_of_string gl l.l_type in - tclTHENS - (assert_tac (Name (id_of_string l.l_id)) ty) - [exact_string l.l_proof; tclIDTAC] - gl - in - tclTHEN (tclMAP interp_lemma ll) (exact_string p) - - let proof_from_file f = - axioms := []; - msgnl (str "proof_from_file " ++ str f); - let zp = read_zenon_proof f in - msgnl (str "proof term is " ++ str (snd zp)); - tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp) - -} diff --git a/contrib/dp/fol.mli b/contrib/dp/fol.mli deleted file mode 100644 index b94bd3e3..00000000 --- a/contrib/dp/fol.mli +++ /dev/null @@ -1,55 +0,0 @@ - -(* Polymorphic First-Order Logic (that is Why's input logic) *) - -type typ = - | Tvar of string - | Tid of string * typ list - -type term = - | Cst of int - | Plus of term * term - | Moins of term * term - | Mult of term * term - | Div of term * term - | App of string * term list - -and atom = - | Eq of term * term - | Le of term * term - | Lt of term * term - | Ge of term * term - | Gt of term * term - | Pred of string * term list - -and form = - | Fatom of atom - | Imp of form * form - | Iff of form * form - | And of form * form - | Or of form * form - | Not of form - | Forall of string * typ * form - | Exists of string * typ * form - | True - | False - -(* the integer indicates the number of type variables *) -type decl = - | DeclType of string * int - | DeclFun of string * int * typ list * typ - | DeclPred of string * int * typ list - | Axiom of string * form - -type query = decl list * form - - -(* prover result *) - -type prover_answer = - | Valid of string option - | Invalid - | DontKnow - | Timeout - | NoAnswer - | Failure of string - diff --git a/contrib/dp/g_dp.ml4 b/contrib/dp/g_dp.ml4 deleted file mode 100644 index 99bcf477..00000000 --- a/contrib/dp/g_dp.ml4 +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *) - -open Dp - -TACTIC EXTEND Simplify - [ "simplify" ] -> [ simplify ] -END - -TACTIC EXTEND Ergo - [ "ergo" ] -> [ ergo ] -END - -TACTIC EXTEND Yices - [ "yices" ] -> [ yices ] -END - -TACTIC EXTEND CVCLite - [ "cvcl" ] -> [ cvc_lite ] -END - -TACTIC EXTEND Harvey - [ "harvey" ] -> [ harvey ] -END - -TACTIC EXTEND Zenon - [ "zenon" ] -> [ zenon ] -END - -TACTIC EXTEND Gwhy - [ "gwhy" ] -> [ gwhy ] -END - -TACTIC EXTEND Gappa_internal - [ "gappa_internal" ] -> [ Dp_gappa.gappa_internal ] -END - -TACTIC EXTEND Gappa - [ "gappa" ] -> [ Dp_gappa.gappa ] -END - -(* should be part of basic tactics syntax *) -TACTIC EXTEND admit - [ "admit" ] -> [ Tactics.admit_as_an_axiom ] -END - -VERNAC COMMAND EXTEND Dp_hint - [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] -END - -VERNAC COMMAND EXTEND Dp_timeout -| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ] -END - -VERNAC COMMAND EXTEND Dp_prelude -| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ] -END - -VERNAC COMMAND EXTEND Dp_predefined -| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ] -END - -VERNAC COMMAND EXTEND Dp_debug -| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ] -END - -VERNAC COMMAND EXTEND Dp_trace -| [ "Dp_trace" ] -> [ dp_trace true ] -END - diff --git a/contrib/dp/test2.v b/contrib/dp/test2.v deleted file mode 100644 index 3e4c0f6d..00000000 --- a/contrib/dp/test2.v +++ /dev/null @@ -1,80 +0,0 @@ -Require Import ZArith. -Require Import Classical. -Require Import List. - -Open Scope list_scope. -Open Scope Z_scope. - -Dp_debug. -Dp_timeout 3. -Require Export zenon. - -Definition neg (z:Z) : Z := match z with - | Z0 => Z0 - | Zpos p => Zneg p - | Zneg p => Zpos p - end. - -Goal forall z, neg (neg z) = z. - Admitted. - -Open Scope nat_scope. -Print plus. - -Goal forall x, x+0=x. - induction x; ergo. - (* simplify resoud le premier, pas le second *) - Admitted. - -Goal 1::2::3::nil = 1::2::(1+2)::nil. - zenon. - Admitted. - -Definition T := nat. -Parameter fct : T -> nat. -Goal fct O = O. - Admitted. - -Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - -Goal even 4%nat. - try zenon. - Admitted. - -Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil. - -Definition head := -fun (A : Set) (l : list A) => -match l with -| nil => None (A:=A) -| x :: _ => Some x -end. - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Admitted. - -(* -BUG avec head prédéfini : manque eta-expansion sur A:Set - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Print value. -Print Some. - -zenon. -*) - -Inductive IN (A:Set) : A -> list A -> Prop := - | IN1 : forall x l, IN A x (x::l) - | IN2: forall x l, IN A x l -> forall y, IN A x (y::l). -Implicit Arguments IN [A]. - -Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l). - zenon. -Print In. diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v deleted file mode 100644 index eb65a59d..00000000 --- a/contrib/dp/test_gappa.v +++ /dev/null @@ -1,91 +0,0 @@ -Require Export Gappa_tactic. -Require Export Reals. - -Open Scope Z_scope. -Open Scope R_scope. - -Lemma test_base10 : - forall x y:R, - 0 <= x <= 4 -> - 0 <= x * (24 * powerRZ 10 (-1)) <= 10. -Proof. - gappa. -Qed. - -(* -@rnd = float< ieee_32, zr >; -a = rnd(a_); b = rnd(b_); -{ a in [3.2,3.3] /\ b in [1.4,1.9] -> - rnd(a - b) - (a - b) in [0,0] } -*) - -Definition rnd := gappa_rounding (rounding_float roundZR 43 (120)). - -Lemma test_float3 : - forall a_ b_ a b : R, - a = rnd a_ -> - b = rnd b_ -> - 52 / 16 <= a <= 53 / 16 -> - 22 / 16 <= b <= 30 / 16 -> - 0 <= rnd (a - b) - (a - b) <= 0. -Proof. - unfold rnd. - gappa. -Qed. - -Lemma test_float2 : - forall x y:R, - 0 <= x <= 1 -> - 0 <= y <= 1 -> - 0 <= gappa_rounding (rounding_float roundNE 53 (1074)) (x+y) <= 2. -Proof. - gappa. -Qed. - -Lemma test_float1 : - forall x y:R, - 0 <= gappa_rounding (rounding_fixed roundDN (0)) x - - gappa_rounding (rounding_fixed roundDN (0)) y <= 0 -> - Rabs (x - y) <= 1. -Proof. - gappa. -Qed. - -Lemma test1 : - forall x y:R, - 0 <= x <= 1 -> - 0 <= -y <= 1 -> - 0 <= x * (-y) <= 1. -Proof. - gappa. -Qed. - -Lemma test2 : - forall x y:R, - 3/4 <= x <= 3 -> - 0 <= sqrt x <= 1775 * (powerRZ 2 (-10)). -Proof. - gappa. -Qed. - -Lemma test3 : - forall x y z:R, - 0 <= x - y <= 3 -> - -2 <= y - z <= 4 -> - -2 <= x - z <= 7. -Proof. - gappa. -Qed. - -Lemma test4 : - forall x1 x2 y1 y2 : R, - 1 <= Rabs y1 <= 1000 -> - 1 <= Rabs y2 <= 1000 -> - - powerRZ 2 (-53) <= (x1 - y1) / y1 <= powerRZ 2 (-53) -> - - powerRZ 2 (-53) <= (x2 - y2) / y2 <= powerRZ 2 (-53) -> - - powerRZ 2 (-51) <= (x1 * x2 - y1 * y2) / (y1 * y2) <= powerRZ 2 (-51). -Proof. - gappa. -Qed. - - diff --git a/contrib/dp/tests.v b/contrib/dp/tests.v deleted file mode 100644 index a6d4f2e1..00000000 --- a/contrib/dp/tests.v +++ /dev/null @@ -1,288 +0,0 @@ - -Require Import ZArith. -Require Import Classical. - -Dp_debug. -Dp_timeout 3. - -(* module renamings *) - -Module M. - Parameter t : Set. -End M. - -Lemma test_module_0 : forall x:M.t, x=x. -ergo. -Qed. - -Module N := M. - -Lemma test_module_renaming_0 : forall x:N.t, x=x. -ergo. -Qed. - -Dp_predefined M.t => "int". - -Lemma test_module_renaming_1 : forall x:N.t, x=x. -ergo. -Qed. - -(* Coq lists *) - -Require Export List. - -Lemma test_pol_0 : forall l:list nat, l=l. -ergo. -Qed. - -Parameter nlist: list nat -> Prop. - -Lemma poly_1 : forall l, nlist l -> True. -intros. -simplify. -Qed. - -(* user lists *) - -Inductive list (A:Set) : Set := -| nil : list A -| cons: forall a:A, list A -> list A. - -Fixpoint app (A:Set) (l m:list A) {struct l} : list A := -match l with -| nil => m -| cons a l1 => cons A a (app A l1 m) -end. - -Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. -intros; ergo. -Qed. - -(* polymorphism *) -Require Import List. - -Inductive mylist (A:Set) : Set := - mynil : mylist A -| mycons : forall a:A, mylist A -> mylist A. - -Parameter my_nlist: mylist nat -> Prop. - - Goal forall l, my_nlist l -> True. - intros. - simplify. -Qed. - -(* First example with the 0 and the equality translated *) - -Goal 0 = 0. -simplify. -Qed. - -(* Examples in the Propositional Calculus - and theory of equality *) - -Parameter A C : Prop. - -Goal A -> A. -simplify. -Qed. - - -Goal A -> (A \/ C). - -simplify. -Qed. - - -Parameter x y z : Z. - -Goal x = y -> y = z -> x = z. -ergo. -Qed. - - -Goal ((((A -> C) -> A) -> A) -> C) -> C. - -ergo. -Qed. - -(* Arithmetic *) -Open Scope Z_scope. - -Goal 1 + 1 = 2. -yices. -Qed. - - -Goal 2*x + 10 = 18 -> x = 4. - -simplify. -Qed. - - -(* Universal quantifier *) - -Goal (forall (x y : Z), x = y) -> 0=1. -try zenon. -ergo. -Qed. - -Goal forall (x: nat), (x + 0 = x)%nat. - -induction x0; ergo. -Qed. - - -(* No decision procedure can solve this problem - Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. -*) - - -(* Functions definitions *) - -Definition fst (x y : Z) : Z := x. - -Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x. - -simplify. -Qed. - - -(* Eta-expansion example *) - -Definition snd_of_3 (x y z : Z) : Z := y. - -Definition f : Z -> Z -> Z := snd_of_3 0. - -Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1. - -simplify. -Qed. - - -(* Inductive types definitions - call to incontrib/dp/jection function *) - -Inductive even : Z -> Prop := -| even_0 : even 0 -| even_plus2 : forall z : Z, even z -> even (z + 2). - - -(* Simplify and Zenon can't prove this goal before the timeout - unlike CVC Lite *) - -Goal even 4. -ergo. -Qed. - - -Definition skip_z (z : Z) (n : nat) := n. - -Definition skip_z1 := skip_z. - -Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n. -yices. -Qed. - - -(* Axioms definitions and dp_hint *) - -Parameter add : nat -> nat -> nat. -Axiom add_0 : forall (n : nat), add 0%nat n = n. -Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). - -Dp_hint add_0. -Dp_hint add_S. - -(* Simplify can't prove this goal before the timeout - unlike zenon *) - -Goal forall n : nat, add n 0 = n. -induction n ; yices. -Qed. - - -Definition pred (n : nat) : nat := match n with - | 0%nat => 0%nat - | S n' => n' -end. - -Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat. -yices. -(*zenon.*) -Qed. - - -Fixpoint plus (n m : nat) {struct n} : nat := - match n with - | 0%nat => m - | S n' => S (plus n' m) -end. - -Goal forall n : nat, plus n 0%nat = n. - -induction n; ergo. -Qed. - - -(* Mutually recursive functions *) - -Fixpoint even_b (n : nat) : bool := match n with - | O => true - | S m => odd_b m -end -with odd_b (n : nat) : bool := match n with - | O => false - | S m => even_b m -end. - -Goal even_b (S (S O)) = true. -ergo. -(* -simplify. -zenon. -*) -Qed. - - -(* sorts issues *) - -Parameter foo : Set. -Parameter ff : nat -> foo -> foo -> nat. -Parameter g : foo -> foo. -Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. -yices. -(*zenon.*) -Qed. - - - -(* abstractions *) - -Parameter poly_f : forall A:Set, A->A. - -Goal forall x:nat, poly_f nat x = poly_f nat x. -ergo. -(*zenon.*) -Qed. - - - -(* Anonymous mutually recursive functions : no equations are produced - -Definition mrf := - fix even2 (n : nat) : bool := match n with - | O => true - | S m => odd2 m - end - with odd2 (n : nat) : bool := match n with - | O => false - | S m => even2 m - end for even. - - Thus this goal is unsolvable - -Goal mrf (S (S O)) = true. - -zenon. - -*) diff --git a/contrib/dp/zenon.v b/contrib/dp/zenon.v deleted file mode 100644 index 4ad00a11..00000000 --- a/contrib/dp/zenon.v +++ /dev/null @@ -1,94 +0,0 @@ -(* Copyright 2004 INRIA *) -(* $Id: zenon.v 10739 2008-04-01 14:45:20Z herbelin $ *) - -Require Export Classical. - -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. diff --git a/contrib/extraction/BUGS b/contrib/extraction/BUGS deleted file mode 100644 index 7f3f59c1..00000000 --- a/contrib/extraction/BUGS +++ /dev/null @@ -1,2 +0,0 @@ -It's not a bug, it's a lack of feature !! -Cf TODO. diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES deleted file mode 100644 index acd1dbda..00000000 --- a/contrib/extraction/CHANGES +++ /dev/null @@ -1,409 +0,0 @@ -7.4 -> 8.0 - -No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, -but also a few steps toward a more user-friendly extraction: - -* syntax of extraction: -- The old (Recursive) Extraction Module M. - is now (Recursive) Extraction Library M. - The old name was misleading since this command only works with M being a - library M.v, and not a module produced by interactive command Module M. -- The other commands - Extraction foo. - Recursive Extraction foo bar. - Extraction "myfile.ml" foo bar. - now accept that foo can be a module name instead of just a constant name. - -* Support of type scheme axioms (i.e. axiom whose type is an arity - (x1:X1)...(xn:Xn)s with s a sort). For example: - - Axiom myprod : Set -> Set -> Set. - Extract Constant myprod "'a" "'b" => "'a * 'b". - Recursive Extraction myprod. - -------> type ('a,'b) myprod = 'a * 'b - -* More flexible support of axioms. When an axiom isn't realized via Extract - Constant before extraction, a warning is produced (instead of an error), - and the extracted code must be completed later by hand. To find what - needs to be completed, search for the following string: AXIOM TO BE REALIZED - -* Cosmetics: When extraction produces a file, it tells it. - -* (Experimental) It is allowed to extract under a opened interactive module - (but still outside sections). Feature to be used with caution. - -* A problem has been identified concerning .v files used as normal interactive - modules, like in - - <file A.v> - Definition foo :=O. - <End file A.v> - - <at toplevel> - Require A. - Module M:=A - Extraction M. - - I might try to support that in the future. In the meanwhile, the - current behaviour of extraction is to forbid this. - -* bug fixes: -- many concerning Records. -- a Stack Overflow with mutual inductive (PR#320) -- some optimizations have been removed since they were not type-safe: - For example if e has type: type 'x a = A - Then: match e with A -> A -----X----> e - To be investigated further. - - -7.3 -> 7.4 - -* The two main new features: - - Automatic generation of Obj.magic when the extracted code - in Ocaml is not directly typable. - - An experimental extraction of Coq's new modules to Ocaml modules. - -* Concerning those Obj.magic: - - The extraction now computes the expected type of any terms. Then - it compares it with the actual type of the produced code. And when - a mismatch is found, a Obj.magic is inserted. - - - As a rule, any extracted development that was compiling out of the box - should not contain any Obj.magic. At the other hand, generation of - Obj.magic is not optimized yet: there might be several of them at a place - were one would have been enough. - - - Examples of code needing those Obj.magic: - * contrib/extraction/test_extraction.v in the Coq source - * in the users' contributions: - Lannion - Lyon/CIRCUITS - Rocq/HIGMAN - - - As a side-effect of this Obj.magic feature, we now print the types - of the extracted terms, both in .ml files as commented documentation - and in interfaces .mli files - - - This feature hasn't been ported yet to Haskell. We are aware of - some unsafe casting functions like "unsafeCoerce" on some Haskell implems. - So it will eventually be done. - -* Concerning the extraction of Coq's new modules: - - Taking in account the new Coq's modules system has implied a *huge* - rewrite of most of the extraction code. - - - The extraction core (translation from Coq to an abstract mini-ML) - is now complete and fairly stable, and supports modules, modules type - and functors and all that stuff. - - - The ocaml pretty-print part, especially the renaming issue, is - clearly weaker, and certainly still contains bugs. - - - Nothing done for translating these Coq Modules to Haskell. - - - A temporary drawback of this module extraction implementation is that - efficiency (especially extraction speed) has been somehow neglected. - To improve ... - - - As an interesting side-effect, definitions are now printed according to - the user's original order. No more of this "dependency-correct but weird" - order. In particular realized axioms via Extract Constant are now at their - right place, and not at the beginning. - -* Other news: - - - Records are now printed using the Ocaml record syntax - - - Syntax output toward Scheme. Quite funny, but quite experimental and - not documented. I recommend using the bigloo compiler since it contains - natively some pattern matching. - - - the dummy constant "__" have changed. see README - - - a few bug-fixes (#191 and others) - -7.2 -> 7.3 - -* Improved documentation in the Reference Manual. - -* Theoretical bad news: -- a naughty example (see the end of test_extraction.v) -forced me to stop eliminating lambdas and arguments corresponding to -so-called "arity" in the general case. - -- The dummy constant used in extraction ( let prop = () in ocaml ) -may in some cases be applied to arguments. This problem is dealt by -generating sufficient abstraction before the (). - - -* Theoretical good news: -- there is now a mechanism that remove useless prop/arity lambdas at the -top of function declarations. If your function had signature -nat -> prop -> nat in the previous extraction, it will now be nat -> nat. -So the extractions of common terms should look very much like the old -V6.2 one, except in some particular cases (functions as parameters, partial -applications, etc). In particular the bad news above have nearly no -impact... - - -* By the way there is no more "let prop = ()" in ocaml. Those () are -directly inlined. And in Haskell the dummy constant is now __ (two -underscore) and is defined by -__ = Prelude.error "Logical or arity value used" -This dummy constant should never be evaluated when computing an -informative value, thanks to the lazy strategy. Hence the error message. - - -* Syntax changes, see Documentation for details: - -Extraction Language Ocaml. -Extraction Language Haskell. -Extraction Language Toplevel. - -That fixes the target language of extraction. Default is Ocaml, even in the -coq toplevel: you can now do copy-paste from the coq toplevel without -renaming problems. Toplevel language is the ocaml pseudo-language used -previously used inside the coq toplevel: coq names are printed with the coq -way, i.e. with no renaming. - -So there is no more particular commands for Haskell, like -Haskell Extraction "file" id. Just set your favourite language and go... - - -* Haskell extraction has been tested at last (and corrected...). -See specificities in Documentation. - - -* Extraction of CoInductive in Ocaml language is now correct: it uses the -Lazy.force and lazy features of Ocaml. - - -* Modular extraction in Ocaml is now far more readable: -instead of qualifying everywhere (A.foo), there are now some "open" at the -beginning of files. Possible clashes are dealt with. - - -* By default, any recursive function associated with an inductive type -(foo_rec and foo_rect when foo is inductive type) will now be inlined -in extracted code. - - -* A few constants are explicitely declared to be inlined in extracted code. -For the moment there are: - Wf.Acc_rec - Wf.Acc_rect - Wf.well_founded_induction - Wf.well_founded_induction_type -Those constants does not match the auto-inlining criterion based on strictness. -Of course, you can still overide this behaviour via some Extraction NoInline. - -* There is now a web page showing the extraction of all standard theories: -http://www.lri.fr/~letouzey/extraction - - -7.1 -> 7.2 : - -* Syntax changes, see Documentation for more details: - -Set/Unset Extraction Optimize. - -Default is Set. This control all optimizations made on the ML terms -(mostly reduction of dummy beta/iota redexes, but also simplications on -Cases, etc). Put this option to Unset if you what a ML term as close as -possible to the Coq term. - -Set/Unset Extraction AutoInline. - -Default in Set, so by default, the extraction mechanism feels free to -inline the bodies of some defined constants, according to some heuristics -like size of bodies, useness of some arguments, etc. Those heuristics are -not always perfect, you may want to disable this feature, do it by Unset. - -Extraction Inline toto foo. -Extraction NoInline titi faa bor. - -In addition to the automatic inline feature, you can now tell precisely to -inline some more constants by the Extraction Inline command. Conversely, -you can forbid the inlining of some specific constants by automatic inlining. -Those two commands enable a precise control of what is inlined and what is not. - -Print Extraction Inline. - -Sum up the current state of the table recording the custom inlings -(Extraction (No)Inline). - -Reset Extraction Inline. - -Put the table recording the custom inlings back to empty. - -As a consequence, there is no more need for options inside the commands of -extraction: - -Extraction foo. -Recursive Extraction foo bar. -Extraction "file" foo bar. -Extraction Module Mymodule. -Recursive Extraction Module Mymodule. - -New: The last syntax extracts the module Mymodule and all the modules -it depends on. - -You can also try the Haskell versions (not tested yet): - -Haskell Extraction foo. -Haskell Recursive Extraction foo bar. -Haskell Extraction "file" foo bar. -Haskell Extraction Module Mymodule. -Haskell Recursive Extraction Module Mymodule. - -And there's still the realization syntax: - -Extract Constant coq_bla => "caml_bla". -Extract Inlined Constant coq_bla => "caml_bla". -Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ]. - -Note that now, the Extract Inlined Constant command is sugar for an Extract -Constant followed by a Extraction Inline. So be careful with -Reset Extraction Inline. - - - -* Lot of works around optimization of produced code. Should make code more -readable. - -- fixpoint definitions : there should be no more stupid printings like - -let foo x = - let rec f x = - .... (f y) .... - in f x - -but rather - -let rec foo x = - .... (foo y) .... - -- generalized iota (in particular iota and permutation cases/cases): - -A generalized iota redex is a "Cases e of ...." where e is ok. -And the recursive predicate "ok" is given by: -e is ok if e is a Constructor or a Cases where all branches are ok. -In the case of generalized iota redex, it might be good idea to reduce it, -so we do it. -Example: - -match (match t with - O -> Left - | S n -> match n with - O -> Right - | S m -> Left) with - Left -> blabla -| Right -> bloblo - -After simplification, that gives: - -match t with - O -> blabla -| S n -> match n with - O -> bloblo - | S n -> blabla - -As shown on the example, code duplication can occur. In practice -it seems not to happen frequently. - -- "constant" case: -In V7.1 we used to simplify cases where all branches are the same. -In V7.2 we can simplify in addition terms like - cases e of - C1 x y -> f (C x y) - | C2 z -> f (C2 z) -If x y z don't occur in f, we can produce (f e). - -- permutation cases/fun: -extracted code has frequenty functions in branches of cases: - -let foo x = match x with - O -> fun _ -> .... - | S y -> fun _ -> .... - -the optimization consist in lifting the common "fun _ ->", and that gives - -let foo x _ = match x with - O -> ..... - | S y -> .... - - -* Some bug corrections (many thanks in particular to Michel Levy). - -* Testing in coq contributions: -If you are interested in extraction, you can look at the extraction tests -I'have put in the following coq contributions - -Bordeaux/Additions computation of fibonacci(2000) -Bordeaux/EXCEPTIONS multiplication using exception. -Bordeaux/SearchTrees list -> binary tree. maximum. -Dyade/BDDS boolean tautology checker. -Lyon/CIRCUITS multiplication via a modelization of a circuit. -Lyon/FIRING-SQUAD print the states of the firing squad. -Marseille/CIRCUITS compares integers via a modelization of a circuit. -Nancy/FOUnify unification of two first-order terms. -Rocq/ARITH/Chinese computation of the chinese remainder. -Rocq/COC small coc typechecker. (test by B. Barras, not by me) -Rocq/HIGMAN run the proof on one example. -Rocq/GRAPHS linear constraints checker in Z. -Sophia-Antipolis/Stalmarck boolean tautology checker. -Suresnes/BDD boolean tautology checker. - -Just do "make" in those contributions, the extraction test is integrated. -More tests will follow on more contributions. - - - -7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with. - -* The semantics of Extract Constant changed: If you provide a extraction -for p by Extract Constant p => "0", your generated ML file will begin by -a let p = 0. The old semantics, which was to replace p everywhere by the -provided terms, is still available via the Extract Inlined Constant p => -"0" syntax. - - -* There are more optimizations applied to the generated code: -- identity cases: match e with P x y -> P x y | Q z -> Q z | ... -is simplified into e. Especially interesting with the sumbool terms: -there will be no more match ... with Left -> Left | Right -> Right - -- constant cases: match e with P x y -> c | Q z -> c | ... -is simplified into c as soon as x, y, z do not occur in c. -So no more match ... with Left -> Left | Right -> Left. - - -* the extraction at Toplevel (Extraction foo and Recursive Extraction foo), -which was only a development tool at the beginning, is now closer to -the real extraction to a file. In particular optimizations are done, -and constants like recursors ( ..._rec ) are expanded. - - -* the singleton optimization is now protected against circular type. -( Remind : this optimization is the one that simplify -type 'a sig = Exists of 'a into type 'a sig = 'a and -match e with (Exists c) -> d into let c = e in d ) - - -* Fixed one bug concerning casted code - - -* The inductives generated should now have always correct type-var list -('a,'b,'c...) - - -* Code cleanup until three days before release. Messing-up code -in the last three days before release. - - - - - - - -6.x -> 7.0 : Everything changed. See README diff --git a/contrib/extraction/README b/contrib/extraction/README deleted file mode 100644 index 7350365e..00000000 --- a/contrib/extraction/README +++ /dev/null @@ -1,139 +0,0 @@ - -Status of Extraction in Coq version 7.x -====================================== - -(* 22 jan 2003 : Updated for version 7.4 *) - - -J.C. Filliâtre -P. Letouzey - - - -Extraction code has been completely rewritten since version V6.3. -This work is still not finished, but most parts of it are already usable. -In consequence it is included in the Coq V7.0 final release. -But don't be mistaken: - - THIS WORK IS STILL EXPERIMENTAL ! - -1) Principles - -The main goal of the new extraction is to handle any Coq term, even -those upon sort Type, and to produce code that always compiles. -Thus it will never answer something like "Not an ML type", but rather -a dummy term like the ML unit. - -Translation between Coq and ML is based upon the following principles: - -- Terms of sort Prop don't have any computational meaning, so they are -merged into one ML term "__". This part is done according to P. Letouzey's -works (*) and (**). - -This dummy constant "__" used to be implemented by the unit (), but -we recently found that this constant might be applied in some cases. -So "__" is now in Ocaml a fixpoint that forgets its arguments: - - let __ = let rec f _ = Obj.repr f in Obj.repr f - - -- Terms that are type schemes (i.e. something of type ( : )( : )...s with -s a sort ) don't have any ML counterpart at the term level, since they -are types transformers. In fact they do not have any computational -meaning either. So we also merge them into that dummy term "__". - -- A Coq term gives a ML term or a ML type depending of its type: -type schemes will (try to) give ML types, and all other terms give ML terms. - -And the rest of the translation is (almost) straightforward: an inductive -gives an inductive, etc... - -This gives ML code that have no special reason to typecheck, due -to the incompatibilities between Coq and ML typing systems. In fact -most of the time everything goes right. For example, it is sufficient -to extract and compile everything in the "theories" directory -(cf test subdirectory). - -We now verify during extraction that the produced code is typecheckable, -and if it is not we insert unsafe type casting at critical points in the -code. For the moment, it is an Ocaml-only feature, using the "Obj.magic" -function, but the same kind of trick will be soon made in Haskell. - - -2) Differences with previous extraction (V6.3 and before) - -2.a) The pros - -The ability to extract every Coq term, as explain in the previous -paragraph. - -The ability to extract from a file an ML module (cf Extraction Module in the -documentation) - -You can have a taste of extraction directly at the toplevel by -using the "Extraction <ident>" or the "Recursive Extraction <ident>". -This toplevel extraction was already there in V6.3, but was printing -Fw terms. It now prints in the language of your choice: -Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. - -The optimization done on extracted code has been ported between -V6.3 and V7 and enhanced, and in particular the mechanism of automatic -expansion. - -2.b) The cons - -The presence of some parasite "__" as dummy arguments -in functions. This denotes the rests of a proof part. The previous -extraction was able to remove them totally. The current implementation -removes a good deal of them (more that in 7.0), but not all. - -This problem is due to extraction upon Type. -For example, let's take this pathological term: - (if b then Set else Prop) : Type -The only way to know if this is an Set (to keep) or a Prop (to remove) -is to compute the boolean b, and we do not want to do that during -extraction. - -There is no more "ML import" feature. You can compensate by using -Axioms, and then "Extract Constant ..." - -3) Examples - -The file "test-extraction.v" is made of some examples used while debugging. - -In the subdirectory "test", you can test extraction on the Coq theories. -Go there. -"make tree" to make a local copy of the "theories" tree -"make" to extract & compile most of the theories file in Ocaml -"make -f Makefile.haskell" to extract & compile in Haskell - -See also Reference Manual for explanation of extraction syntaxes -and more examples. - - -(*): -Exécution de termes de preuves: une nouvelle méthode d'extraction -pour le Calcul des Constructions Inductives, Pierre Letouzey, -DEA thesis, 2000, -http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz - -(**) -A New Extraction for Coq, Pierre Letouzey, -Types 2002 Post-Workshop Proceedings, to appear, -draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz - - -Any feedback is welcome: -Pierre.Letouzey@lri.fr -Jean.Christophe.Filliatre@lri.fr - - - - - - - - - - - diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO deleted file mode 100644 index 174be06e..00000000 --- a/contrib/extraction/TODO +++ /dev/null @@ -1,31 +0,0 @@ - - 16. Haskell : - - equivalent of Obj.magic (unsafeCoerce ?) - - look again at the syntax (make it independant of layout ...) - - producing .hi files - - modules/modules types/functors in Haskell ? - - 17. Scheme : - - modular Scheme ? - - 18. Improve speed (profiling) - - 19. Look again at those hugly renamings functions. - Especially get rid of ML clashes like - - let t = 0 - module M = struct - let t = 1 - let u = The.External.t (* ?? *) - end - - 20. Support the .v-as-internal-module, like in - - <file A.v> - Definition foo :=O. - <End file A.v> - - <at toplevel> - Require A. - Module M:=A - Extraction M.
\ No newline at end of file diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml deleted file mode 100644 index 73f44e68..00000000 --- a/contrib/extraction/common.ml +++ /dev/null @@ -1,444 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: common.ml 13200 2010-06-25 22:36:25Z letouzey $ i*) - -open Pp -open Util -open Names -open Term -open Declarations -open Nameops -open Libnames -open Table -open Miniml -open Mlutil -open Modutil -open Mod_subst - -let string_of_id id = ascii_of_ident (Names.string_of_id id) - -(*s Some pretty-print utility functions. *) - -let pp_par par st = if par then str "(" ++ st ++ str ")" else st - -let pp_apply st par args = match args with - | [] -> st - | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) - -let pr_binding = function - | [] -> mt () - | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l - -let fnl2 () = fnl () ++ fnl () - -let space_if = function true -> str " " | false -> mt () - -let sec_space_if = function true -> spc () | false -> mt () - -let is_digit = function - | '0'..'9' -> true - | _ -> false - -let begins_with_CoqXX s = - let n = String.length s in - n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' && - let i = ref 3 in - try while !i < n do - if s.[!i] = '_' then i:=n (*Stop*) - else if is_digit s.[!i] then incr i - else raise Not_found - done; true - with Not_found -> false - -let unquote s = - if lang () <> Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done; - s - -let rec dottify = function - | [] -> assert false - | [s] -> s - | s::[""] -> s - | s::l -> (dottify l)^"."^s - -(*s Uppercase/lowercase renamings. *) - -let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false -let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false - -let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) -let uppercase_id id = - let s = string_of_id id in - assert (s<>""); - if s.[0] = '_' then id_of_string ("Coq_"^s) - else id_of_string (String.capitalize s) - -type kind = Term | Type | Cons | Mod - -let upperkind = function - | Type -> lang () = Haskell - | Term -> false - | Cons | Mod -> true - -let kindcase_id k id = - if upperkind k then uppercase_id id else lowercase_id id - -(*s de Bruijn environments for programs *) - -type env = identifier list * Idset.t - -(*s Generic renaming issues for local variable names. *) - -let rec rename_id id avoid = - if Idset.mem id avoid then rename_id (lift_ident id) avoid else id - -let rec rename_vars avoid = function - | [] -> - [], avoid - | id :: idl when id == dummy_name -> - (* we don't rename dummy binders *) - let (idl', avoid') = rename_vars avoid idl in - (id :: idl', avoid') - | id :: idl -> - let (idl, avoid) = rename_vars avoid idl in - let id = rename_id (lowercase_id id) avoid in - (id :: idl, Idset.add id avoid) - -let rename_tvars avoid l = - let rec rename avoid = function - | [] -> [],avoid - | id :: idl -> - let id = rename_id (lowercase_id id) avoid in - let idl, avoid = rename (Idset.add id avoid) idl in - (id :: idl, avoid) in - fst (rename avoid l) - -let push_vars ids (db,avoid) = - let ids',avoid' = rename_vars avoid ids in - ids', (ids' @ db, avoid') - -let get_db_name n (db,_) = - let id = List.nth db (pred n) in - if id = dummy_name then id_of_string "__" else id - - -(*S Renamings of global objects. *) - -(*s Tables of global renamings *) - -let register_cleanup, do_cleanup = - let funs = ref [] in - (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs) - -type phase = Pre | Impl | Intf - -let set_phase, get_phase = - let ph = ref Impl in ((:=) ph), (fun () -> !ph) - -let set_keywords, get_keywords = - let k = ref Idset.empty in - ((:=) k), (fun () -> !k) - -let add_global_ids, get_global_ids = - let ids = ref Idset.empty in - register_cleanup (fun () -> ids := get_keywords ()); - let add s = ids := Idset.add s !ids - and get () = !ids - in (add,get) - -let empty_env () = [], get_global_ids () - -let mktable autoclean = - let h = Hashtbl.create 97 in - if autoclean then register_cleanup (fun () -> Hashtbl.clear h); - (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) - -(* A table recording objects in the first level of all MPfile *) - -let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = - mktable false - -(*s The list of external modules that will be opened initially *) - -let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear = - let m = ref MPset.empty in - let add mp = m:=MPset.add mp !m - and mem mp = MPset.mem mp !m - and list () = MPset.elements !m - and clear () = m:=MPset.empty - in - register_cleanup clear; - (add,mem,list,clear) - -(*s table indicating the visible horizon at a precise moment, - i.e. the stack of structures we are inside. - - - The sequence of [mp] parts should have the following form: - [X.Y; X; A.B.C; A.B; A; ...], i.e. each addition should either - be a [MPdot] over the last entry, or something new, mainly - [MPself], or [MPfile] at the beginning. - - - The [content] part is used to recoard all the names already - seen at this level. - - - The [subst] part is here mainly for printing signature - (in which names are still short, i.e. relative to a [msid]). -*) - -type visible_layer = { mp : module_path; - content : ((kind*string),unit) Hashtbl.t } - -let pop_visible, push_visible, get_visible, subst_mp = - let vis = ref [] and sub = ref [empty_subst] in - register_cleanup (fun () -> vis := []; sub := [empty_subst]); - let pop () = - let v = List.hd !vis in - (* we save the 1st-level-content of MPfile for later use *) - if get_phase () = Impl && modular () && is_modfile v.mp - then add_mpfiles_content v.mp v.content; - vis := List.tl !vis; - sub := List.tl !sub - and push mp o = - vis := { mp = mp; content = Hashtbl.create 97 } :: !vis; - let s = List.hd !sub in - let s = match o with None -> s | Some msid -> add_msid msid mp s in - sub := s :: !sub - and get () = !vis - and subst mp = subst_mp (List.hd !sub) mp - in (pop,push,get,subst) - -let get_visible_mps () = List.map (function v -> v.mp) (get_visible ()) -let top_visible () = match get_visible () with [] -> assert false | v::_ -> v -let top_visible_mp () = (top_visible ()).mp -let add_visible ks = Hashtbl.add (top_visible ()).content ks () - -(* table of local module wrappers used to provide non-ambiguous names *) - -let add_duplicate, check_duplicate = - let index = ref 0 and dups = ref Gmap.empty in - register_cleanup (fun () -> index := 0; dups := Gmap.empty); - let add mp l = - incr index; - let ren = "Coq__" ^ string_of_int (!index) in - dups := Gmap.add (mp,l) ren !dups - and check mp l = Gmap.find (subst_mp mp, l) !dups - in (add,check) - -type reset_kind = AllButExternal | Everything - -let reset_renaming_tables flag = - do_cleanup (); - if flag = Everything then clear_mpfiles_content () - -(*S Renaming functions *) - -(* This function creates from [id] a correct uppercase/lowercase identifier. - This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes - with previous [Coq_id] variable, these prefixes are duplicated if already - existing. *) - -let modular_rename k id = - let s = string_of_id id in - let prefix,is_ok = - if upperkind k then "Coq_",is_upper else "coq_",is_lower - in - if not (is_ok s) || - (Idset.mem id (get_keywords ())) || - (String.length s >= 4 && String.sub s 0 4 = prefix) - then prefix ^ s - else s - -(*s For monolithic extraction, first-level modules might have to be renamed - with unique numbers *) - -let modfstlev_rename = - let add_prefixes,get_prefixes,_ = mktable true in - fun l -> - let coqid = id_of_string "Coq" in - let id = id_of_label l in - try - let coqset = get_prefixes id in - let nextcoq = next_ident_away coqid coqset in - add_prefixes id (nextcoq::coqset); - (string_of_id nextcoq)^"_"^(string_of_id id) - with Not_found -> - let s = string_of_id id in - if is_lower s || begins_with_CoqXX s then - (add_prefixes id [coqid]; "Coq_"^s) - else - (add_prefixes id []; s) - -(*s Creating renaming for a [module_path] : first, the real function ... *) - -let rec mp_renaming_fun mp = match mp with - | _ when not (modular ()) && at_toplevel mp -> [""] - | MPdot (mp,l) -> - let lmp = mp_renaming mp in - if lmp = [""] then (modfstlev_rename l)::lmp - else (modular_rename Mod (id_of_label l))::lmp - | MPself msid -> [modular_rename Mod (id_of_msid msid)] - | MPbound mbid -> [modular_rename Mod (id_of_mbid mbid)] - | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *) - | MPfile _ -> - assert (get_phase () = Pre); - let current_mpfile = (list_last (get_visible ())).mp in - if mp <> current_mpfile then mpfiles_add mp; - [string_of_modfile mp] - -(* ... and its version using a cache *) - -and mp_renaming = - let add,get,_ = mktable true in - fun x -> try get x with Not_found -> let y = mp_renaming_fun x in add x y; y - -(*s Renamings creation for a [global_reference]: we build its fully-qualified - name in a [string list] form (head is the short name). *) - -let ref_renaming_fun (k,r) = - let mp = subst_mp (modpath_of_r r) in - let l = mp_renaming mp in - let s = - if l = [""] (* this happens only at toplevel of the monolithic case *) - then - let globs = Idset.elements (get_global_ids ()) in - let id = next_ident_away (kindcase_id k (safe_id_of_global r)) globs in - string_of_id id - else modular_rename k (safe_id_of_global r) - in - add_global_ids (id_of_string s); - s::l - -(* Cached version of the last function *) - -let ref_renaming = - let add,get,_ = mktable true in - fun x -> try get x with Not_found -> let y = ref_renaming_fun x in add x y; y - -(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] - can be printed as [s] in the current context of visible - modules. More precisely, we check if there exists a - visible [mp] that contains [s]. - The verification stops if we encounter [mp=mp0]. *) - -let rec clash mem mp0 ks = function - | [] -> false - | mp :: _ when mp = mp0 -> false - | mp :: _ when mem mp ks -> true - | _ :: mpl -> clash mem mp0 ks mpl - -let mpfiles_clash mp0 ks = - clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks - (List.rev (mpfiles_list ())) - -let visible_clash mp0 ks = - let rec clash = function - | [] -> false - | v :: _ when v.mp = mp0 -> false - | v :: _ when Hashtbl.mem v.content ks -> true - | _ :: vis -> clash vis - in clash (get_visible ()) - -(* After the 1st pass, we can decide which modules will be opened initially *) - -let opened_libraries () = - if not (modular ()) then [] - else - let used = mpfiles_list () in - let rec check_elsewhere avoid = function - | [] -> [] - | mp :: mpl -> - let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in - if List.exists clash avoid - then check_elsewhere avoid mpl - else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl - in - let opened = check_elsewhere [] used in - mpfiles_clear (); - List.iter mpfiles_add opened; - opened - -(*s On-the-fly qualification issues for both monolithic or modular extraction. *) - -(* First, a function that factorize the printing of both [global_reference] - and module names for ocaml. When [k=Mod] then [olab=None], otherwise it - contains the label of the reference to print. - Invariant: [List.length ls >= 2], simpler situations are handled elsewhere. *) - -let pp_gen k mp ls olab = - try (* what is the largest prefix of [mp] that belongs to [visible]? *) - let prefix = common_prefix_from_list mp (get_visible_mps ()) in - let delta = mp_length mp - mp_length prefix in - assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *) - let ls = list_firstn (delta + if k = Mod then 0 else 1) ls in - let s,ls' = list_sep_last ls in - (* Reference r / module path mp is of the form [<prefix>.s.<List.rev ls'>]. - Difficulty: in ocaml the prefix part cannot be used for - qualification (we are inside it) and the rest of the long - name may be hidden. - Solution: we duplicate the _definition_ of r / mp in a Coq__XXX module *) - let k' = if ls' = [] then k else Mod in - if visible_clash prefix (k',s) then - let front = if ls' = [] && k <> Mod then [s] else ls' in - let lab = (* label associated with s *) - if delta = 0 && k <> Mod then Option.get olab - else get_nth_label_mp delta mp - in - try dottify (front @ [check_duplicate prefix lab]) - with Not_found -> - assert (get_phase () = Pre); (* otherwise it's too late *) - add_duplicate prefix lab; dottify ls - else dottify ls - with Not_found -> - (* [mp] belongs to a closed module, not one of [visible]. *) - let base = base_mp mp in - let base_s,ls1 = list_sep_last ls in - let s,ls2 = list_sep_last ls1 in - (* [List.rev ls] is [base_s :: s :: List.rev ls2] *) - let k' = if ls2 = [] then k else Mod in - if modular () && (mpfiles_mem base) && - (not (mpfiles_clash base (k',s))) && - (not (visible_clash base (k',s))) - then (* Standard situation of an object in another file: *) - (* Thanks to the "open" of this file we remove its name *) - dottify ls1 - else if visible_clash base (Mod,base_s) then - error_module_clash base_s - else dottify ls - -let pp_global k r = - let ls = ref_renaming (k,r) in - assert (List.length ls > 1); - let s = List.hd ls in - let mp = subst_mp (modpath_of_r r) in - if mp = top_visible_mp () then - (* simpliest situation: definition of r (or use in the same context) *) - (* we update the visible environment *) - (add_visible (k,s); unquote s) - else match lang () with - | Scheme -> unquote s (* no modular Scheme extraction... *) - | Haskell -> if modular () then dottify ls else s - (* for the moment we always qualify in modular Haskell... *) - | Ocaml -> pp_gen k mp ls (Some (label_of_r r)) - -(* The next function is used only in Ocaml extraction...*) -let pp_module mp = - let mp = subst_mp mp in - let ls = mp_renaming mp in - if List.length ls = 1 then dottify ls - else match mp with - | MPdot (mp0,_) when mp0 = top_visible_mp () -> - (* simpliest situation: definition of mp (or use in the same context) *) - (* we update the visible environment *) - let s = List.hd ls in - add_visible (Mod,s); s - | _ -> pp_gen Mod mp ls None - - diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli deleted file mode 100644 index b7e70414..00000000 --- a/contrib/extraction/common.mli +++ /dev/null @@ -1,57 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: common.mli 11559 2008-11-07 22:03:34Z letouzey $ i*) - -open Names -open Libnames -open Miniml -open Mlutil -open Pp - -val fnl2 : unit -> std_ppcmds -val space_if : bool -> std_ppcmds -val sec_space_if : bool -> std_ppcmds - -val pp_par : bool -> std_ppcmds -> std_ppcmds -val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds -val pr_binding : identifier list -> std_ppcmds - -val rename_id : identifier -> Idset.t -> identifier - -type env = identifier list * Idset.t -val empty_env : unit -> env - -val rename_vars: Idset.t -> identifier list -> env -val rename_tvars: Idset.t -> identifier list -> identifier list -val push_vars : identifier list -> env -> identifier list * env -val get_db_name : int -> env -> identifier - -type phase = Pre | Impl | Intf - -val set_phase : phase -> unit -val get_phase : unit -> phase - -val opened_libraries : unit -> module_path list - -type kind = Term | Type | Cons | Mod - -val pp_global : kind -> global_reference -> string -val pp_module : module_path -> string - -val top_visible_mp : unit -> module_path -val push_visible : module_path -> mod_self_id option -> unit -val pop_visible : unit -> unit - -val check_duplicate : module_path -> label -> string - -type reset_kind = AllButExternal | Everything - -val reset_renaming_tables : reset_kind -> unit - -val set_keywords : Idset.t -> unit diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml deleted file mode 100644 index 057a7b29..00000000 --- a/contrib/extraction/extract_env.ml +++ /dev/null @@ -1,529 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: extract_env.ml 13201 2010-06-25 22:36:27Z letouzey $ i*) - -open Term -open Declarations -open Names -open Libnames -open Pp -open Util -open Miniml -open Table -open Extraction -open Modutil -open Common -open Mod_subst - -(***************************************) -(*S Part I: computing Coq environment. *) -(***************************************) - -let toplevel_env () = - let seg = Lib.contents_after None in - let get_reference = function - | (_,kn), Lib.Leaf o -> - let mp,_,l = repr_kn kn in - let seb = match Libobject.object_tag o with - | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn)) - | "INDUCTIVE" -> SFBmind (Global.lookup_mind kn) - | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l))) - | "MODULE TYPE" -> - SFBmodtype (Global.lookup_modtype (MPdot (mp,l))) - | _ -> failwith "caught" - in l,seb - | _ -> failwith "caught" - in - match current_toplevel () with - | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg)) - | _ -> assert false - -let environment_until dir_opt = - let rec parse = function - | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] - | [] -> [] - | d :: l -> - match (Global.lookup_module (MPfile d)).mod_expr with - | Some meb -> - if dir_opt = Some d then [MPfile d, meb] - else (MPfile d, meb) :: (parse l) - | _ -> assert false - in parse (Library.loaded_libraries ()) - - -(*s Visit: - a structure recording the needed dependencies for the current extraction *) - -module type VISIT = sig - (* Reset the dependencies by emptying the visit lists *) - val reset : unit -> unit - - (* Add the module_path and all its prefixes to the mp visit list *) - val add_mp : module_path -> unit - - (* Add kernel_name / constant / reference / ... in the visit lists. - These functions silently add the mp of their arg in the mp list *) - val add_kn : kernel_name -> unit - val add_con : constant -> unit - val add_ref : global_reference -> unit - val add_decl_deps : ml_decl -> unit - val add_spec_deps : ml_spec -> unit - - (* Test functions: - is a particular object a needed dependency for the current extraction ? *) - val needed_kn : kernel_name -> bool - val needed_con : constant -> bool - val needed_mp : module_path -> bool -end - -module Visit : VISIT = struct - (* What used to be in a single KNset should now be split into a KNset - (for inductives and modules names) and a Cset for constants - (and still the remaining MPset) *) - type must_visit = - { mutable kn : KNset.t; mutable con : Cset.t; mutable mp : MPset.t } - (* the imperative internal visit lists *) - let v = { kn = KNset.empty ; con = Cset.empty ; mp = MPset.empty } - (* the accessor functions *) - let reset () = v.kn <- KNset.empty; v.con <- Cset.empty; v.mp <- MPset.empty - let needed_kn kn = KNset.mem kn v.kn - let needed_con c = Cset.mem c v.con - let needed_mp mp = MPset.mem mp v.mp - let add_mp mp = - check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp - let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) - let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c) - let add_ref = function - | ConstRef c -> add_con c - | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn - | VarRef _ -> assert false - let add_decl_deps = decl_iter_references add_ref add_ref add_ref - let add_spec_deps = spec_iter_references add_ref add_ref add_ref -end - -exception Impossible - -let check_arity env cb = - let t = Typeops.type_of_constant_type env cb.const_type in - if Reduction.is_arity env t then raise Impossible - -let check_fix env cb i = - match cb.const_body with - | None -> raise Impossible - | Some lbody -> - match kind_of_term (Declarations.force lbody) with - | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd) - | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd) - | _ -> raise Impossible - -let factor_fix env l cb msb = - let _,recd as check = check_fix env cb 0 in - let n = Array.length (let fi,_,_ = recd in fi) in - if n = 1 then [|l|], recd, msb - else begin - if List.length msb < n-1 then raise Impossible; - let msb', msb'' = list_chop (n-1) msb in - let labels = Array.make n l in - list_iter_i - (fun j -> - function - | (l,SFBconst cb') -> - if check <> check_fix env cb' (j+1) then raise Impossible; - labels.(j+1) <- l; - | _ -> raise Impossible) msb'; - labels, recd, msb'' - end - -let build_mb expr typ_opt = - { mod_expr = Some expr; - mod_type = typ_opt; - mod_constraints = Univ.Constraint.empty; - mod_alias = Mod_subst.empty_subst; - mod_retroknowledge = [] } - -let my_type_of_mb env mb = - match mb.mod_type with - | Some mtb -> mtb - | None -> Modops.eval_struct env (Option.get mb.mod_expr) - -(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. - To check with Elie. *) - -let env_for_mtb_with env mtb idl = - let msid,sig_b = match Modops.eval_struct env mtb with - | SEBstruct(msid,sig_b) -> msid,sig_b - | _ -> assert false - in - let l = label_of_id (List.hd idl) in - let before = fst (list_split_at (fun (l',_) -> l=l') sig_b) in - Modops.add_signature (MPself msid) before env - -(* From a [structure_body] (i.e. a list of [structure_field_body]) - to specifications. *) - -let rec extract_sfb_spec env mp = function - | [] -> [] - | (l,SFBconst cb) :: msig -> - let kn = make_con mp empty_dirpath l in - let s = extract_constant_spec env kn cb in - let specs = extract_sfb_spec env mp msig in - if logical_spec s then specs - else begin Visit.add_spec_deps s; (l,Spec s) :: specs end - | (l,SFBmind _) :: msig -> - let kn = make_kn mp empty_dirpath l in - let s = Sind (kn, extract_inductive env kn) in - let specs = extract_sfb_spec env mp msig in - if logical_spec s then specs - else begin Visit.add_spec_deps s; (l,Spec s) :: specs end - | (l,SFBmodule mb) :: msig -> - let specs = extract_sfb_spec env mp msig in - let spec = extract_seb_spec env (my_type_of_mb env mb) in - (l,Smodule spec) :: specs - | (l,SFBmodtype mtb) :: msig -> - let specs = extract_sfb_spec env mp msig in - (l,Smodtype (extract_seb_spec env mtb.typ_expr)) :: specs - | (l,SFBalias(mp1,typ_opt,_))::msig -> - let mb = build_mb (SEBident mp1) typ_opt in - extract_sfb_spec env mp ((l,SFBmodule mb) :: msig) - -(* From [struct_expr_body] to specifications *) - -(* Invariant: the [seb] given to [extract_seb_spec] should either come: - - from a [mod_type] or [type_expr] field - - from the output of [Modops.eval_struct]. - This way, any encountered [SEBident] should be a true module type. - For instance, [my_type_of_mb] ensures this invariant. -*) - -and extract_seb_spec env = function - | SEBident mp -> Visit.add_mp mp; MTident mp - | SEBwith(mtb',With_definition_body(idl,cb))-> - let env' = env_for_mtb_with env mtb' idl in - let mtb''= extract_seb_spec env mtb' in - (match extract_with_type env' cb with (* cb peut contenir des kn *) - | None -> mtb'' - | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ))) - | SEBwith(mtb',With_module_body(idl,mp,_,_))-> - Visit.add_mp mp; - MTwith(extract_seb_spec env mtb', - ML_With_module(idl,mp)) -(* TODO: On pourrait peut-etre oter certaines eta-expansion, du genre: - | SEBfunctor(mbid,_,SEBapply(m,SEBident (MPbound mbid2),_)) - when mbid = mbid2 -> extract_seb_spec env m - (* faudrait alors ajouter un test de non-apparition de mbid dans mb *) -*) - | SEBfunctor (mbid, mtb, mtb') -> - let mp = MPbound mbid in - let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MTfunsig (mbid, extract_seb_spec env mtb.typ_expr, - extract_seb_spec env' mtb') - | SEBstruct (msid, msig) -> - let mp = MPself msid in - let env' = Modops.add_signature mp msig env in - MTsig (msid, extract_sfb_spec env' mp msig) - | SEBapply _ as mtb -> - extract_seb_spec env (Modops.eval_struct env mtb) - - -(* From a [structure_body] (i.e. a list of [structure_field_body]) - to implementations. - - NB: when [all=false], the evaluation order of the list is - important: last to first ensures correct dependencies. -*) - -let rec extract_sfb env mp all = function - | [] -> [] - | (l,SFBconst cb) :: msb -> - (try - let vl,recd,msb = factor_fix env l cb msb in - let vc = Array.map (make_con mp empty_dirpath) vl in - let ms = extract_sfb env mp all msb in - let b = array_exists Visit.needed_con vc in - if all || b then - let d = extract_fixpoint env vc recd in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end - else ms - with Impossible -> - let ms = extract_sfb env mp all msb in - let c = make_con mp empty_dirpath l in - let b = Visit.needed_con c in - if all || b then - let d = extract_constant env c cb in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end - else ms) - | (l,SFBmind mib) :: msb -> - let ms = extract_sfb env mp all msb in - let kn = make_kn mp empty_dirpath l in - let b = Visit.needed_kn kn in - if all || b then - let d = Dind (kn, extract_inductive env kn) in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end - else ms - | (l,SFBmodule mb) :: msb -> - let ms = extract_sfb env mp all msb in - let mp = MPdot (mp,l) in - if all || Visit.needed_mp mp then - (l,SEmodule (extract_module env mp true mb)) :: ms - else ms - | (l,SFBmodtype mtb) :: msb -> - let ms = extract_sfb env mp all msb in - let mp = MPdot (mp,l) in - if all || Visit.needed_mp mp then - (l,SEmodtype (extract_seb_spec env mtb.typ_expr)) :: ms - else ms - | (l,SFBalias (mp1,typ_opt,_)) :: msb -> - let mb = build_mb (SEBident mp1) typ_opt in - extract_sfb env mp all ((l,SFBmodule mb) :: msb) - -(* From [struct_expr_body] to implementations *) - -and extract_seb env mpo all = function - | SEBident mp -> - if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; - Visit.add_mp mp; MEident mp - | SEBapply (meb, meb',_) -> - MEapply (extract_seb env None true meb, - extract_seb env None true meb') - | SEBfunctor (mbid, mtb, meb) -> - let mp = MPbound mbid in - let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in - MEfunctor (mbid, extract_seb_spec env mtb.typ_expr, - extract_seb env' None true meb) - | SEBstruct (msid, msb) -> - let mp,msb = match mpo with - | None -> MPself msid, msb - | Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb - in - let env' = Modops.add_signature mp msb env in - MEstruct (msid, extract_sfb env' mp all msb) - | SEBwith (_,_) -> anomaly "Not available yet" - -and extract_module env mp all mb = - (* [mb.mod_expr <> None ], since we look at modules from outside. *) - (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) - { ml_mod_expr = extract_seb env (Some mp) all (Option.get mb.mod_expr); - ml_mod_type = extract_seb_spec env (my_type_of_mb env mb) } - - -let unpack = function MEstruct (_,sel) -> sel | _ -> assert false - -let mono_environment refs mpl = - Visit.reset (); - List.iter Visit.add_ref refs; - List.iter Visit.add_mp mpl; - let env = Global.env () in - let l = List.rev (environment_until None) in - List.rev_map - (fun (mp,m) -> mp, unpack (extract_seb env (Some mp) false m)) l - -(**************************************) -(*S Part II : Input/Output primitives *) -(**************************************) - -let descr () = match lang () with - | Ocaml -> Ocaml.ocaml_descr - | Haskell -> Haskell.haskell_descr - | Scheme -> Scheme.scheme_descr - -(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" - Works similarly for the other languages. *) - -let default_id = id_of_string "Main" - -let mono_filename f = - let d = descr () in - match f with - | None -> None, None, default_id - | Some f -> - let f = - if Filename.check_suffix f d.file_suffix then - Filename.chop_suffix f d.file_suffix - else f - in - let id = - if lang () <> Haskell then default_id - else try id_of_string (Filename.basename f) - with _ -> error "Extraction: provided filename is not a valid identifier" - in - Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id - -(* Builds a suitable filename from a module id *) - -let module_filename fc = - let d = descr () in - let fn = if d.capital_file then fc else String.uncapitalize fc - in - Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, id_of_string fc - -(*s Extraction of one decl to stdout. *) - -let print_one_decl struc mp decl = - let d = descr () in - reset_renaming_tables AllButExternal; - set_phase Pre; - ignore (d.pp_struct struc); - set_phase Impl; - push_visible mp None; - msgnl (d.pp_decl decl); - pop_visible () - -(*s Extraction of a ml struct to a file. *) - -let formatter dry file = - if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) - else match file with - | None -> !Pp_control.std_ft - | Some cout -> - let ft = Pp_control.with_output_to cout in - Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ()); - ft - -let print_structure_to_file (fn,si,mo) dry struc = - let d = descr () in - reset_renaming_tables AllButExternal; - let unsafe_needs = { - mldummy = struct_ast_search ((=) MLdummy) struc; - tdummy = struct_type_search Mlutil.isDummy struc; - tunknown = struct_type_search ((=) Tunknown) struc; - magic = - if lang () <> Haskell then false - else struct_ast_search (function MLmagic _ -> true | _ -> false) struc } - in - (* First, a dry run, for computing objects to rename or duplicate *) - set_phase Pre; - let devnull = formatter true None in - msg_with devnull (d.pp_struct struc); - let opened = opened_libraries () in - (* Print the implementation *) - let cout = if dry then None else Option.map open_out fn in - let ft = formatter dry cout in - begin try - (* The real printing of the implementation *) - set_phase Impl; - msg_with ft (d.preamble mo opened unsafe_needs); - msg_with ft (d.pp_struct struc); - Option.iter close_out cout; - with e -> - Option.iter close_out cout; raise e - end; - if not dry then Option.iter info_file fn; - (* Now, let's print the signature *) - Option.iter - (fun si -> - let cout = open_out si in - let ft = formatter false (Some cout) in - begin try - set_phase Intf; - msg_with ft (d.sig_preamble mo opened unsafe_needs); - msg_with ft (d.pp_sig (signature_of_structure struc)); - close_out cout; - with e -> - close_out cout; raise e - end; - info_file si) - (if dry then None else si) - - -(*********************************************) -(*s Part III: the actual extraction commands *) -(*********************************************) - - -let reset () = - Visit.reset (); reset_tables (); reset_renaming_tables Everything - -let init modular = - check_inside_section (); check_inside_module (); - set_keywords (descr ()).keywords; - set_modular modular; - reset (); - if modular && lang () = Scheme then error_scheme () - -(* From a list of [reference], let's retrieve whether they correspond - to modules or [global_reference]. Warn the user if both is possible. *) - -let rec locate_ref = function - | [] -> [],[] - | r::l -> - let q = snd (qualid_of_reference r) in - let mpo = try Some (Nametab.locate_module q) with Not_found -> None - and ro = try Some (Nametab.locate q) with Not_found -> None in - match mpo, ro with - | None, None -> Nametab.error_global_not_found q - | None, Some r -> let refs,mps = locate_ref l in r::refs,mps - | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps - | Some mp, Some r -> - warning_both_mod_and_cst q mp r; - let refs,mps = locate_ref l in refs,mp::mps - -(*s Recursive extraction in the Coq toplevel. The vernacular command is - \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when - extracting to a file with the command: - \verb!Extraction "file"! [qualid1] ... [qualidn]. *) - -let full_extr f (refs,mps) = - init false; - List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; - let struc = optimize_struct refs (mono_environment refs mps) in - warning_axioms (); - print_structure_to_file (mono_filename f) false struc; - reset () - -let full_extraction f lr = full_extr f (locate_ref lr) - - -(*s Simple extraction in the Coq toplevel. The vernacular command - is \verb!Extraction! [qualid]. *) - -let simple_extraction r = match locate_ref [r] with - | ([], [mp]) as p -> full_extr None p - | [r],[] -> - init false; - let struc = optimize_struct [r] (mono_environment [r] []) in - let d = get_decl_in_structure r struc in - warning_axioms (); - if is_custom r then msgnl (str "(** User defined extraction *)"); - print_one_decl struc (modpath_of_r r) d; - reset () - | _ -> assert false - - -(*s (Recursive) Extraction of a library. The vernacular command is - \verb!(Recursive) Extraction Library! [M]. *) - -let extraction_library is_rec m = - init true; - let dir_m = - let q = make_short_qualid m in - try Nametab.full_name_module q with Not_found -> error_unknown_module q - in - Visit.add_mp (MPfile dir_m); - let env = Global.env () in - let l = List.rev (environment_until (Some dir_m)) in - let select l (mp,meb) = - if Visit.needed_mp mp - then (mp, unpack (extract_seb env (Some mp) true meb)) :: l - else l - in - let struc = List.fold_left select [] l in - let struc = optimize_struct [] struc in - warning_axioms (); - let print = function - | (MPfile dir as mp, sel) as e -> - let dry = not is_rec && dir <> dir_m in - let s = string_of_modfile mp in - print_structure_to_file (module_filename s) dry [e] - | _ -> assert false - in - List.iter print struc; - reset () diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli deleted file mode 100644 index 8d906985..00000000 --- a/contrib/extraction/extract_env.mli +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: extract_env.mli 10895 2008-05-07 16:06:26Z letouzey $ i*) - -(*s This module declares the extraction commands. *) - -open Names -open Libnames - -val simple_extraction : reference -> unit -val full_extraction : string option -> reference list -> unit -val extraction_library : bool -> identifier -> unit - -(* For debug / external output via coqtop.byte + Drop : *) - -val mono_environment : - global_reference list -> module_path list -> Miniml.ml_structure diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml deleted file mode 100644 index 2cf457c6..00000000 --- a/contrib/extraction/extraction.ml +++ /dev/null @@ -1,917 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: extraction.ml 11897 2009-02-09 19:28:02Z barras $ i*) - -(*i*) -open Util -open Names -open Term -open Declarations -open Environ -open Reduction -open Reductionops -open Inductive -open Termops -open Inductiveops -open Recordops -open Nameops -open Summary -open Libnames -open Nametab -open Miniml -open Table -open Mlutil -(*i*) - -exception I of inductive_info - -(* A set of all fixpoint functions currently being extracted *) -let current_fixpoints = ref ([] : constant list) - -let none = Evd.empty - -let type_of env c = Retyping.get_type_of env none (strip_outer_cast c) - -let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c) - -let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None - -(*S Generation of flags and signatures. *) - -(* The type [flag] gives us information about any Coq term: - \begin{itemize} - \item [TypeScheme] denotes a type scheme, that is - something that will become a type after enough applications. - More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with - [s = Set], [Prop] or [Type] - \item [Default] denotes the other cases. It may be inexact after - instanciation. For example [(X:Type)X] is [Default] and may give [Set] - after instanciation, which is rather [TypeScheme] - \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop] - \item [Info] is the opposite. The same example [(X:Type)X] shows - that an [Info] term might in fact be [Logic] later on. - \end{itemize} *) - -type info = Logic | Info - -type scheme = TypeScheme | Default - -type flag = info * scheme - -(*s [flag_of_type] transforms a type [t] into a [flag]. - Really important function. *) - -let rec flag_of_type env t = - let t = whd_betadeltaiota env none t in - match kind_of_term t with - | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c - | Sort (Prop Null) -> (Logic,TypeScheme) - | Sort _ -> (Info,TypeScheme) - | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default) - -(*s Two particular cases of [flag_of_type]. *) - -let is_default env t = (flag_of_type env t = (Info, Default)) - -exception NotDefault of kill_reason - -let check_default env t = - match flag_of_type env t with - | _,TypeScheme -> raise (NotDefault Ktype) - | Logic,_ -> raise (NotDefault Kother) - | _ -> () - -let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) - -(*s [type_sign] gernerates a signature aimed at treating a type application. *) - -let rec type_sign env c = - match kind_of_term (whd_betadeltaiota env none c) with - | Prod (n,t,d) -> - (if is_info_scheme env t then Keep else Kill Kother) - :: (type_sign (push_rel_assum (n,t) env) d) - | _ -> [] - -let rec type_scheme_nb_args env c = - match kind_of_term (whd_betadeltaiota env none c) with - | Prod (n,t,d) -> - let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in - if is_info_scheme env t then n+1 else n - | _ -> 0 - -let _ = register_type_scheme_nb_args type_scheme_nb_args - -(*s [type_sign_vl] does the same, plus a type var list. *) - -let rec type_sign_vl env c = - match kind_of_term (whd_betadeltaiota env none c) with - | Prod (n,t,d) -> - let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in - if not (is_info_scheme env t) then Kill Kother::s, vl - else Keep::s, (next_ident_away (id_of_name n) vl) :: vl - | _ -> [],[] - -let rec nb_default_params env c = - match kind_of_term (whd_betadeltaiota env none c) with - | Prod (n,t,d) -> - let n = nb_default_params (push_rel_assum (n,t) env) d in - if is_default env t then n+1 else n - | _ -> 0 - -(*S Management of type variable contexts. *) - -(* A De Bruijn variable context (db) is a context for translating Coq [Rel] - into ML type [Tvar]. *) - -(*s From a type signature toward a type variable context (db). *) - -let db_from_sign s = - let rec make i acc = function - | [] -> acc - | Keep :: l -> make (i+1) (i::acc) l - | Kill _ :: l -> make i (0::acc) l - in make 1 [] s - -(*s Create a type variable context from indications taken from - an inductive type (see just below). *) - -let rec db_from_ind dbmap i = - if i = 0 then [] - else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1)) - -(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument - of a constructor corresponds to the j-th type var of the ML inductive. *) - -(* \begin{itemize} - \item [si] : signature of the inductive - \item [i] : counter of Coq args for [(I args)] - \item [j] : counter of ML type vars - \item [relmax] : total args number of the constructor - \end{itemize} *) - -let parse_ind_args si args relmax = - let rec parse i j = function - | [] -> Intmap.empty - | Kill _ :: s -> parse (i+1) j s - | Keep :: s -> - (match kind_of_term args.(i-1) with - | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s) - | _ -> parse (i+1) (j+1) s) - in parse 1 1 si - -(*S Extraction of a type. *) - -(* [extract_type env db c args] is used to produce an ML type from the - coq term [(c args)], which is supposed to be a Coq type. *) - -(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) - -(* [j] stands for the next ML type var. [j=0] means we do not - generate ML type var anymore (in subterms for example). *) - - -let rec extract_type env db j c args = - match kind_of_term (whd_betaiotazeta Evd.empty c) with - | App (d, args') -> - (* We just accumulate the arguments. *) - extract_type env db j d (Array.to_list args' @ args) - | Lambda (_,_,d) -> - (match args with - | [] -> assert false (* otherwise the lambda would be reductible. *) - | a :: args -> extract_type env db j (subst1 a d) args) - | Prod (n,t,d) -> - assert (args = []); - let env' = push_rel_assum (n,t) env in - (match flag_of_type env t with - | (Info, Default) -> - (* Standard case: two [extract_type] ... *) - let mld = extract_type env' (0::db) j d [] in - (match expand env mld with - | Tdummy d -> Tdummy d - | _ -> Tarr (extract_type env db 0 t [], mld)) - | (Info, TypeScheme) when j > 0 -> - (* A new type var. *) - let mld = extract_type env' (j::db) (j+1) d [] in - (match expand env mld with - | Tdummy d -> Tdummy d - | _ -> Tarr (Tdummy Ktype, mld)) - | _,lvl -> - let mld = extract_type env' (0::db) j d [] in - (match expand env mld with - | Tdummy d -> Tdummy d - | _ -> - let reason = if lvl=TypeScheme then Ktype else Kother in - Tarr (Tdummy reason, mld))) - | Sort _ -> Tdummy Ktype (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother - | Rel n -> - (match lookup_rel n env with - | (_,Some t,_) -> extract_type env db j (lift n t) args - | _ -> - (* Asks [db] a translation for [n]. *) - if n > List.length db then Tunknown - else let n' = List.nth db (n-1) in - if n' = 0 then Tunknown else Tvar n') - | Const kn -> - let r = ConstRef kn in - let cb = lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in - (match flag_of_type env typ with - | (Info, TypeScheme) -> - let mlt = extract_type_app env db (r, type_sign env typ) args in - (match cb.const_body with - | None -> mlt - | Some _ when is_custom r -> mlt - | Some lbody -> - let newc = applist (Declarations.force lbody, args) in - let mlt' = extract_type env db j newc [] in - (* ML type abbreviations interact badly with Coq *) - (* reduction, so [mlt] and [mlt'] might be different: *) - (* The more precise is [mlt'], extracted after reduction *) - (* The shortest is [mlt], which use abbreviations *) - (* If possible, we take [mlt], otherwise [mlt']. *) - if expand env mlt = expand env mlt' then mlt else mlt') - | _ -> (* only other case here: Info, Default, i.e. not an ML type *) - (match cb.const_body with - | None -> Tunknown (* Brutal approximation ... *) - | Some lbody -> - (* We try to reduce. *) - let newc = applist (Declarations.force lbody, args) in - extract_type env db j newc [])) - | Ind (kn,i) -> - let s = (extract_ind env kn).ind_packets.(i).ip_sign in - extract_type_app env db (IndRef (kn,i),s) args - | Case _ | Fix _ | CoFix _ -> Tunknown - | _ -> assert false - -(* [extract_maybe_type] calls [extract_type] when used on a Coq type, - and otherwise returns [Tdummy] or [Tunknown] *) - -and extract_maybe_type env db c = - let t = whd_betadeltaiota env none (type_of env c) in - if isSort t then extract_type env db 0 c [] - else if sort_of env t = InProp then Tdummy Kother else Tunknown - -(*s Auxiliary function dealing with type application. - Precondition: [r] is a type scheme represented by the signature [s], - and is completely applied: [List.length args = List.length s]. *) - -and extract_type_app env db (r,s) args = - let ml_args = - List.fold_right - (fun (b,c) a -> if b=Keep then - let p = List.length (fst (splay_prod env none (type_of env c))) in - let db = iterate (fun l -> 0 :: l) p db in - (extract_type_scheme env db c p) :: a - else a) - (List.combine s args) [] - in Tglob (r, ml_args) - -(*S Extraction of a type scheme. *) - -(* [extract_type_scheme env db c p] works on a Coq term [c] which is - an informative type scheme. It means that [c] is not a Coq type, but will - be when applied to sufficiently many arguments ([p] in fact). - This function decomposes p lambdas, with eta-expansion if needed. *) - -(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) - -and extract_type_scheme env db c p = - if p=0 then extract_type env db 0 c [] - else - let c = whd_betaiotazeta Evd.empty c in - match kind_of_term c with - | Lambda (n,t,d) -> - extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) - | _ -> - let rels = fst (splay_prod env none (type_of env c)) in - let env = push_rels_assum rels env in - let eta_args = List.rev_map mkRel (interval 1 p) in - extract_type env db 0 (lift p c) eta_args - - -(*S Extraction of an inductive type. *) - -and extract_ind env kn = (* kn is supposed to be in long form *) - let mib = Environ.lookup_mind kn env in - try - (* For a same kn, we can get various bodies due to module substitutions. - We hence check that the mib has not changed from recording - time to retrieving time. Ideally we should also check the env. *) - let (mib0,ml_ind) = lookup_ind kn in - if not (mib = mib0) then raise Not_found; - ml_ind - with Not_found -> - (* First, if this inductive is aliased via a Module, *) - (* we process the original inductive. *) - Option.iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv; - (* Everything concerning parameters. *) - (* We do that first, since they are common to all the [mib]. *) - let mip0 = mib.mind_packets.(0) in - let npar = mib.mind_nparams in - let epar = push_rel_context mib.mind_params_ctxt env in - (* First pass: we store inductive signatures together with *) - (* their type var list. *) - let packets = - Array.map - (fun mip -> - let b = snd (mind_arity mip) <> InProp in - let ar = Inductive.type_of_inductive env (mib,mip) in - let s,v = if b then type_sign_vl env ar else [],[] in - let t = Array.make (Array.length mip.mind_nf_lc) [] in - { ip_typename = mip.mind_typename; - ip_consnames = mip.mind_consnames; - ip_logical = (not b); - ip_sign = s; - ip_vars = v; - ip_types = t }) - mib.mind_packets - in - add_ind kn mib - {ind_info = Standard; - ind_nparams = npar; - ind_packets = packets; - ind_equiv = match mib.mind_equiv with - | None -> NoEquiv - | Some kn -> Equiv kn - }; - (* Second pass: we extract constructors *) - for i = 0 to mib.mind_ntypes - 1 do - let p = packets.(i) in - if not p.ip_logical then - let types = arities_of_constructors env (kn,i) in - for j = 0 to Array.length types - 1 do - let t = snd (decompose_prod_n npar types.(j)) in - let prods,head = dest_prod epar t in - let nprods = List.length prods in - let args = match kind_of_term head with - | App (f,args) -> args (* [kind_of_term f = Ind ip] *) - | _ -> [||] - in - let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in - let db = db_from_ind dbmap npar in - p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1) - done - done; - (* Third pass: we determine special cases. *) - let ind_info = - try - if not mib.mind_finite then raise (I Coinductive); - if mib.mind_ntypes <> 1 then raise (I Standard); - let p = packets.(0) in - if p.ip_logical then raise (I Standard); - if Array.length p.ip_types <> 1 then raise (I Standard); - let typ = p.ip_types.(0) in - let l = List.filter (fun t -> not (isDummy (expand env t))) typ in - if List.length l = 1 && not (type_mem_kn kn (List.hd l)) - then raise (I Singleton); - if l = [] then raise (I Standard); - if not mib.mind_record then raise (I Standard); - let ip = (kn, 0) in - let r = IndRef ip in - if is_custom r then raise (I Standard); - (* Now we're sure it's a record. *) - (* First, we find its field names. *) - let rec names_prod t = match kind_of_term t with - | Prod(n,_,t) -> n::(names_prod t) - | LetIn(_,_,_,t) -> names_prod t - | Cast(t,_,_) -> names_prod t - | _ -> [] - in - let field_names = - list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in - assert (List.length field_names = List.length typ); - let projs = ref Cset.empty in - let mp,d,_ = repr_kn kn in - let rec select_fields l typs = match l,typs with - | [],[] -> [] - | (Name id)::l, typ::typs -> - if isDummy (expand env typ) then select_fields l typs - else - let knp = make_con mp d (label_of_id id) in - if not (List.exists isKill (type2signature env typ)) - then - projs := Cset.add knp !projs; - (ConstRef knp) :: (select_fields l typs) - | Anonymous::l, typ::typs -> - if isDummy (expand env typ) then select_fields l typs - else error_record r - | _ -> assert false - in - let field_glob = select_fields field_names typ - in - (* Is this record officially declared with its projections ? *) - (* If so, we use this information. *) - begin try - let n = nb_default_params env - (Inductive.type_of_inductive env (mib,mip0)) - in - List.iter - (Option.iter - (fun kn -> if Cset.mem kn !projs then add_projection n kn)) - (lookup_projections ip) - with Not_found -> () - end; - Record field_glob - with (I info) -> info - in - let i = {ind_info = ind_info; - ind_nparams = npar; - ind_packets = packets; - ind_equiv = match mib.mind_equiv with - | None -> NoEquiv - | Some kn -> Equiv kn } - in - add_ind kn mib i; - i - -(*s [extract_type_cons] extracts the type of an inductive - constructor toward the corresponding list of ML types. *) - -(* \begin{itemize} - \item [db] is a context for translating Coq [Rel] into ML type [Tvar] - \item [dbmap] is a translation map (produced by a call to [parse_in_args]) - \item [i] is the rank of the current product (initially [params_nb+1]) - \end{itemize} *) - -and extract_type_cons env db dbmap c i = - match kind_of_term (whd_betadeltaiota env none c) with - | Prod (n,t,d) -> - let env' = push_rel_assum (n,t) env in - let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in - let l = extract_type_cons env' db' dbmap d (i+1) in - (extract_type env db 0 t []) :: l - | _ -> [] - -(*s Recording the ML type abbreviation of a Coq type scheme constant. *) - -and mlt_env env r = match r with - | ConstRef kn -> - (try - if not (visible_con kn) then raise Not_found; - match lookup_term kn with - | Dtype (_,vl,mlt) -> Some mlt - | _ -> None - with Not_found -> - let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type in - match cb.const_body with - | None -> None - | Some l_body -> - (match flag_of_type env typ with - | Info,TypeScheme -> - let body = Declarations.force l_body in - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db body (List.length s) - in add_term kn (Dtype (r, vl, t)); Some t - | _ -> None)) - | _ -> None - -and expand env = type_expand (mlt_env env) -and type2signature env = type_to_signature (mlt_env env) -let type2sign env = type_to_sign (mlt_env env) -let type_expunge env = type_expunge (mlt_env env) - -(*s Extraction of the type of a constant. *) - -let record_constant_type env kn opt_typ = - try - if not (visible_con kn) then raise Not_found; - lookup_type kn - with Not_found -> - let typ = match opt_typ with - | None -> Typeops.type_of_constant env kn - | Some typ -> typ - in let mlt = extract_type env [] 1 typ [] - in let schema = (type_maxvar mlt, mlt) - in add_type kn schema; schema - -(*S Extraction of a term. *) - -(* Precondition: [(c args)] is not a type scheme, and is informative. *) - -(* [mle] is a ML environment [Mlenv.t]. *) -(* [mlt] is the ML type we want our extraction of [(c args)] to have. *) - -let rec extract_term env mle mlt c args = - match kind_of_term c with - | App (f,a) -> - extract_term env mle mlt f (Array.to_list a @ args) - | Lambda (n, t, d) -> - let id = id_of_name n in - (match args with - | a :: l -> - (* We make as many [LetIn] as possible. *) - let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l)) - in extract_term env mle mlt d' [] - | [] -> - let env' = push_rel_assum (Name id, t) env in - let id, a = try check_default env t; id, new_meta() - with NotDefault d -> dummy_name, Tdummy d - in - let b = new_meta () in - (* If [mlt] cannot be unified with an arrow type, then magic! *) - let magic = needs_magic (mlt, Tarr (a, b)) in - let d' = extract_term env' (Mlenv.push_type mle a) b d [] in - put_magic_if magic (MLlam (id, d'))) - | LetIn (n, c1, t1, c2) -> - let id = id_of_name n in - let env' = push_rel (Name id, Some c1, t1) env in - let args' = List.map (lift 1) args in - (try - check_default env t1; - let a = new_meta () in - let c1' = extract_term env mle a c1 [] in - (* The type of [c1'] is generalized and stored in [mle]. *) - let mle' = Mlenv.push_gen mle a in - MLletin (id, c1', extract_term env' mle' mlt c2 args') - with NotDefault d -> - let mle' = Mlenv.push_std_type mle (Tdummy d) in - ast_pop (extract_term env' mle' mlt c2 args')) - | Const kn -> - extract_cst_app env mle mlt kn args - | Construct cp -> - extract_cons_app env mle mlt cp args - | Rel n -> - (* As soon as the expected [mlt] for the head is known, *) - (* we unify it with an fresh copy of the stored type of [Rel n]. *) - let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) - in extract_app env mle mlt extract_rel args - | Case ({ci_ind=ip},_,c0,br) -> - extract_app env mle mlt (extract_case env mle (ip,c0,br)) args - | Fix ((_,i),recd) -> - extract_app env mle mlt (extract_fix env mle i recd) args - | CoFix (i,recd) -> - extract_app env mle mlt (extract_fix env mle i recd) args - | Cast (c,_,_) -> extract_term env mle mlt c args - | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false - -(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) - -and extract_maybe_term env mle mlt c = - try check_default env (type_of env c); - extract_term env mle mlt c [] - with NotDefault d -> - put_magic (mlt, Tdummy d) MLdummy - -(*s Generic way to deal with an application. *) - -(* We first type all arguments starting with unknown meta types. - This gives us the expected type of the head. Then we use the - [mk_head] to produce the ML head from this type. *) - -and extract_app env mle mlt mk_head args = - let metas = List.map new_meta args in - let type_head = type_recomp (metas, mlt) in - let mlargs = List.map2 (extract_maybe_term env mle) metas args in - if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs) - -(*s Auxiliary function used to extract arguments of constant or constructor. *) - -and make_mlargs env e s args typs = - let l = ref s in - let keep () = match !l with [] -> true | b :: s -> l:=s; b=Keep in - let rec f = function - | [], [] -> [] - | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt)) - | _::la, _::lt -> f (la,lt) - | _ -> assert false - in f (args,typs) - -(*s Extraction of a constant applied to arguments. *) - -and extract_cst_app env mle mlt kn args = - (* First, the [ml_schema] of the constant, in expanded version. *) - let nb,t = record_constant_type env kn None in - let schema = nb, expand env t in - (* Can we instantiate types variables for this constant ? *) - (* In Ocaml, inside the definition of this constant, the answer is no. *) - let instantiated = - if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema) - else instantiation schema - in - (* Then the expected type of this constant. *) - let a = new_meta () in - (* We compare stored and expected types in two steps. *) - (* First, can [kn] be applied to all args ? *) - let metas = List.map new_meta args in - let magic1 = needs_magic (type_recomp (metas, a), instantiated) in - (* Second, is the resulting type compatible with the expected type [mlt] ? *) - let magic2 = needs_magic (a, mlt) in - (* The internal head receives a magic if [magic1] *) - let head = put_magic_if magic1 (MLglob (ConstRef kn)) in - (* Now, the extraction of the arguments. *) - let s = type2signature env (snd schema) in - let ls = List.length s in - let la = List.length args in - let mla = make_mlargs env mle s args metas in - let mla = - if not magic1 then - try - let l,l' = list_chop (projection_arity (ConstRef kn)) mla in - if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' - else mla - with _ -> mla - else mla - in - (* Different situations depending of the number of arguments: *) - if ls = 0 then put_magic_if magic2 head - else if List.mem Keep s then - if la >= ls || not (List.exists isKill s) - then - put_magic_if (magic2 && not magic1) (MLapp (head, mla)) - else - (* Not enough arguments. We complete via eta-expansion. *) - let ls' = ls-la in - let s' = list_lastn ls' s in - let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in - put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s') - else if List.mem (Kill Kother) s then - (* In the special case of always false signature, one dummy lam is left. *) - (* So a [MLdummy] is left accordingly. *) - if la >= ls - then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla)) - else put_magic_if magic2 (dummy_lams head (ls-la-1)) - else (* s is made only of [Kill Ktype] *) - if la >= ls - then put_magic_if (magic2 && not magic1) (MLapp (head, mla)) - else put_magic_if magic2 (dummy_lams head (ls-la)) - - -(*s Extraction of an inductive constructor applied to arguments. *) - -(* \begin{itemize} - \item In ML, contructor arguments are uncurryfied. - \item We managed to suppress logical parts inside inductive definitions, - but they must appears outside (for partial applications for instance) - \item We also suppressed all Coq parameters to the inductives, since - they are fixed, and thus are not used for the computation. - \end{itemize} *) - -and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = - (* First, we build the type of the constructor, stored in small pieces. *) - let mi = extract_ind env kn in - let params_nb = mi.ind_nparams in - let oi = mi.ind_packets.(i) in - let nb_tvars = List.length oi.ip_vars - and types = List.map (expand env) oi.ip_types.(j-1) in - let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in - let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in - let type_cons = instantiation (nb_tvars, type_cons) in - (* Then, the usual variables [s], [ls], [la], ... *) - let s = List.map (type2sign env) types in - let ls = List.length s in - let la = List.length args in - assert (la <= ls + params_nb); - let la' = max 0 (la - params_nb) in - let args' = list_lastn la' args in - (* Now, we build the expected type of the constructor *) - let metas = List.map new_meta args' in - (* If stored and expected types differ, then magic! *) - let a = new_meta () in - let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in - let magic2 = needs_magic (a, mlt) in - let head mla = - if mi.ind_info = Singleton then - put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) - else put_magic_if magic1 (MLcons (mi.ind_info, ConstructRef cp, mla)) - in - (* Different situations depending of the number of arguments: *) - if la < params_nb then - let head' = head (eta_args_sign ls s) in - put_magic_if magic2 - (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la)) - else - let mla = make_mlargs env mle s args' metas in - if la = ls + params_nb - then put_magic_if (magic2 && not magic1) (head mla) - else (* [ params_nb <= la <= ls + params_nb ] *) - let ls' = params_nb + ls - la in - let s' = list_lastn ls' s in - let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in - put_magic_if magic2 (anonym_or_dummy_lams (head mla) s') - -(*S Extraction of a case. *) - -and extract_case env mle ((kn,i) as ip,c,br) mlt = - (* [br]: bodies of each branch (in functional form) *) - (* [ni]: number of arguments without parameters in each branch *) - let ni = mis_constr_nargs_env env ip in - let br_size = Array.length br in - assert (Array.length ni = br_size); - if br_size = 0 then begin - add_recursors env kn; (* May have passed unseen if logical ... *) - MLexn "absurd case" - end else - (* [c] has an inductive type, and is not a type scheme type. *) - let t = type_of env c in - (* The only non-informative case: [c] is of sort [Prop] *) - if (sort_of env t) = InProp then - begin - add_recursors env kn; (* May have passed unseen if logical ... *) - (* Logical singleton case: *) - (* [match c with C i j k -> t] becomes [t'] *) - assert (br_size = 1); - let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in - let e = extract_maybe_term env mle mlt br.(0) in - snd (case_expunge s e) - end - else - let mi = extract_ind env kn in - let oi = mi.ind_packets.(i) in - let metas = Array.init (List.length oi.ip_vars) new_meta in - (* The extraction of the head. *) - let type_head = Tglob (IndRef ip, Array.to_list metas) in - let a = extract_term env mle type_head c [] in - (* The extraction of each branch. *) - let extract_branch i = - (* The types of the arguments of the corresponding constructor. *) - let f t = type_subst_vect metas (expand env t) in - let l = List.map f oi.ip_types.(i) in - (* the corresponding signature *) - let s = List.map (type2sign env) oi.ip_types.(i) in - (* Extraction of the branch (in functional form). *) - let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in - (* We suppress dummy arguments according to signature. *) - let ids,e = case_expunge s e in - (ConstructRef (ip,i+1), List.rev ids, e) - in - if mi.ind_info = Singleton then - begin - (* Informative singleton case: *) - (* [match c with C i -> t] becomes [let i = c' in t'] *) - assert (br_size = 1); - let (_,ids,e') = extract_branch 0 in - assert (List.length ids = 1); - MLletin (List.hd ids,a,e') - end - else - (* Standard case: we apply [extract_branch]. *) - MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch) - -(*s Extraction of a (co)-fixpoint. *) - -and extract_fix env mle i (fi,ti,ci as recd) mlt = - let env = push_rec_types recd env in - let metas = Array.map new_meta fi in - metas.(i) <- mlt; - let mle = Array.fold_left Mlenv.push_type mle metas in - let ei = array_map2 (extract_maybe_term env mle) metas ci in - MLfix (i, Array.map id_of_name fi, ei) - -(*S ML declarations. *) - -(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], - and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) - -let rec decomp_lams_eta_n n env c t = - let rels = fst (decomp_n_prod env none n t) in - let rels = List.map (fun (id,_,c) -> (id,c)) rels in - let m = nb_lam c in - if m >= n then decompose_lam_n n c - else - let rels',c = decompose_lam c in - let d = n - m in - (* we'd better keep rels' as long as possible. *) - let rels = (list_firstn d rels) @ rels' in - let eta_args = List.rev_map mkRel (interval 1 d) in - rels, applist (lift d c,eta_args) - -(*s From a constant to a ML declaration. *) - -let extract_std_constant env kn body typ = - reset_meta_count (); - (* The short type [t] (i.e. possibly with abbreviations). *) - let t = snd (record_constant_type env kn (Some typ)) in - (* The real type [t']: without head lambdas, expanded, *) - (* and with [Tvar] translated to [Tvar'] (not instantiable). *) - let l,t' = type_decomp (expand env (var2var' t)) in - let s = List.map (type2sign env) l in - (* The initial ML environment. *) - let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in - (* Decomposing the top level lambdas of [body]. *) - let rels,c = decomp_lams_eta_n (List.length s) env body typ in - (* The lambdas names. *) - let ids = List.map (fun (n,_) -> id_of_name n) rels in - (* The according Coq environment. *) - let env = push_rels_assum rels env in - (* The real extraction: *) - let e = extract_term env mle t' c [] in - (* Expunging term and type from dummy lambdas. *) - term_expunge s (ids,e), type_expunge env t - -let extract_fixpoint env vkn (fi,ti,ci) = - let n = Array.length vkn in - let types = Array.make n (Tdummy Kother) - and terms = Array.make n MLdummy in - let kns = Array.to_list vkn in - current_fixpoints := kns; - (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) - let sub = List.rev_map mkConst kns in - for i = 0 to n-1 do - if sort_of env ti.(i) <> InProp then begin - let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in - terms.(i) <- e; - types.(i) <- t; - end - done; - current_fixpoints := []; - Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) - -let extract_constant env kn cb = - let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in - match cb.const_body with - | None -> (* A logical axiom is risky, an informative one is fatal. *) - (match flag_of_type env typ with - | (Info,TypeScheme) -> - if not (is_custom r) then add_info_axiom r; - let n = type_scheme_nb_args env typ in - let ids = iterate (fun l -> anonymous::l) n [] in - Dtype (r, ids, Taxiom) - | (Info,Default) -> - if not (is_custom r) then add_info_axiom r; - let t = snd (record_constant_type env kn (Some typ)) in - Dterm (r, MLaxiom, type_expunge env t) - | (Logic,TypeScheme) -> - add_log_axiom r; Dtype (r, [], Tdummy Ktype) - | (Logic,Default) -> - add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother)) - | Some body -> - (match flag_of_type env typ with - | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother) - | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype) - | (Info, Default) -> - let e,t = extract_std_constant env kn (force body) typ in - Dterm (r,e,t) - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) - in Dtype (r, vl, t)) - -let extract_constant_spec env kn cb = - let r = ConstRef kn in - let typ = Typeops.type_of_constant_type env cb.const_type in - match flag_of_type env typ with - | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) - | (Logic, Default) -> Sval (r, Tdummy Kother) - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - (match cb.const_body with - | None -> Stype (r, vl, None) - | Some body -> - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) - in Stype (r, vl, Some t)) - | (Info, Default) -> - let t = snd (record_constant_type env kn (Some typ)) in - Sval (r, type_expunge env t) - -let extract_with_type env cb = - let typ = Typeops.type_of_constant_type env cb.const_type in - match flag_of_type env typ with - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - let body = Option.get cb.const_body in - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) in - Some (vl, t) - | _ -> None - - -let extract_inductive env kn = - let ind = extract_ind env kn in - add_recursors env kn; - let f l = List.filter (fun t -> not (isDummy (expand env t))) l in - let packets = - Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) - ind.ind_packets - in { ind with ind_packets = packets } - -(*s Is a [ml_decl] logical ? *) - -let logical_decl = function - | Dterm (_,MLdummy,Tdummy _) -> true - | Dtype (_,[],Tdummy _) -> true - | Dfix (_,av,tv) -> - (array_for_all ((=) MLdummy) av) && - (array_for_all isDummy tv) - | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets - | _ -> false - -(*s Is a [ml_spec] logical ? *) - -let logical_spec = function - | Stype (_, [], Some (Tdummy _)) -> true - | Sval (_,Tdummy _) -> true - | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets - | _ -> false diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli deleted file mode 100644 index 6d41b630..00000000 --- a/contrib/extraction/extraction.mli +++ /dev/null @@ -1,34 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*) - -(*s Extraction from Coq terms to Miniml. *) - -open Names -open Term -open Declarations -open Environ -open Libnames -open Miniml - -val extract_constant : env -> constant -> constant_body -> ml_decl - -val extract_constant_spec : env -> constant -> constant_body -> ml_spec - -val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option - -val extract_fixpoint : - env -> constant array -> (constr, types) prec_declaration -> ml_decl - -val extract_inductive : env -> kernel_name -> ml_ind - -(*s Is a [ml_decl] or a [ml_spec] logical ? *) - -val logical_decl : ml_decl -> bool -val logical_spec : ml_spec -> bool diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 deleted file mode 100644 index 345cb307..00000000 --- a/contrib/extraction/g_extraction.ml4 +++ /dev/null @@ -1,123 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* ML names *) - -open Vernacexpr -open Pcoq -open Genarg -open Pp - -let pr_mlname _ _ _ s = spc () ++ qs s - -ARGUMENT EXTEND mlname - TYPED AS string - PRINTED BY pr_mlname -| [ preident(id) ] -> [ id ] -| [ string(s) ] -> [ s ] -END - -open Table -open Extract_env - -let pr_language = function - | Ocaml -> str "Ocaml" - | Haskell -> str "Haskell" - | Scheme -> str "Scheme" - -VERNAC ARGUMENT EXTEND language -PRINTED BY pr_language -| [ "Ocaml" ] -> [ Ocaml ] -| [ "Haskell" ] -> [ Haskell ] -| [ "Scheme" ] -> [ Scheme ] -END - -(* Extraction commands *) - -VERNAC COMMAND EXTEND Extraction -(* Extraction in the Coq toplevel *) -| [ "Extraction" global(x) ] -> [ simple_extraction x ] -| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] - -(* Monolithic extraction to a file *) -| [ "Extraction" string(f) ne_global_list(l) ] - -> [ full_extraction (Some f) l ] -END - -(* Modular extraction (one Coq library = one ML module) *) -VERNAC COMMAND EXTEND ExtractionLibrary -| [ "Extraction" "Library" ident(m) ] - -> [ extraction_library false m ] -END - -VERNAC COMMAND EXTEND RecursiveExtractionLibrary -| [ "Recursive" "Extraction" "Library" ident(m) ] - -> [ extraction_library true m ] -END - -(* Target Language *) -VERNAC COMMAND EXTEND ExtractionLanguage -| [ "Extraction" "Language" language(l) ] - -> [ extraction_language l ] -END - -VERNAC COMMAND EXTEND ExtractionInline -(* Custom inlining directives *) -| [ "Extraction" "Inline" ne_global_list(l) ] - -> [ extraction_inline true l ] -END - -VERNAC COMMAND EXTEND ExtractionNoInline -| [ "Extraction" "NoInline" ne_global_list(l) ] - -> [ extraction_inline false l ] -END - -VERNAC COMMAND EXTEND PrintExtractionInline -| [ "Print" "Extraction" "Inline" ] - -> [ print_extraction_inline () ] -END - -VERNAC COMMAND EXTEND ResetExtractionInline -| [ "Reset" "Extraction" "Inline" ] - -> [ reset_extraction_inline () ] -END - -VERNAC COMMAND EXTEND ExtractionBlacklist -(* Force Extraction to not use some filenames *) -| [ "Extraction" "Blacklist" ne_ident_list(l) ] - -> [ extraction_blacklist l ] -END - -VERNAC COMMAND EXTEND PrintExtractionBlacklist -| [ "Print" "Extraction" "Blacklist" ] - -> [ print_extraction_blacklist () ] -END - -VERNAC COMMAND EXTEND ResetExtractionBlacklist -| [ "Reset" "Extraction" "Blacklist" ] - -> [ reset_extraction_blacklist () ] -END - - -(* Overriding of a Coq object by an ML one *) -VERNAC COMMAND EXTEND ExtractionConstant -| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] - -> [ extract_constant_inline false x idl y ] -END - -VERNAC COMMAND EXTEND ExtractionInlinedConstant -| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] - -> [ extract_constant_inline true x [] y ] -END - -VERNAC COMMAND EXTEND ExtractionInductive -| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ] - -> [ extract_inductive x (id,idl) ] -END diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml deleted file mode 100644 index 3f0366e6..00000000 --- a/contrib/extraction/haskell.ml +++ /dev/null @@ -1,334 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: haskell.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) - -(*s Production of Haskell syntax. *) - -open Pp -open Util -open Names -open Nameops -open Libnames -open Table -open Miniml -open Mlutil -open Common - -(*s Haskell renaming issues. *) - -let pr_lower_id id = str (String.uncapitalize (string_of_id id)) -let pr_upper_id id = str (String.capitalize (string_of_id id)) - -let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) - [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; - "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; - "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; - "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] - Idset.empty - -let preamble mod_name used_modules usf = - let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") - in - (if not usf.magic then mt () - else - str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++ - str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n") - ++ - str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ - str "import qualified Prelude" ++ fnl () ++ - prlist pp_import used_modules ++ fnl () ++ - (if used_modules = [] then mt () else fnl ()) ++ - (if not usf.magic then mt () - else str "\ -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.Base -unsafeCoerce = GHC.Base.unsafeCoerce# -#else --- HUGS -import qualified IOExts -unsafeCoerce = IOExts.unsafeCoerce -#endif" ++ fnl2 ()) - ++ - (if not usf.mldummy then mt () - else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) - -let pp_abst = function - | [] -> (mt ()) - | l -> (str "\\" ++ - prlist_with_sep (fun () -> (str " ")) pr_id l ++ - str " ->" ++ spc ()) - -(*s The pretty-printer for haskell syntax *) - -let pp_global k r = - if is_inline_custom r then str (find_custom r) - else str (Common.pp_global k r) - -(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses - are needed or not. *) - -let kn_sig = - let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in - make_kn specif empty_dirpath (mk_label "sig") - -let rec pp_type par vl t = - let rec pp_rec par = function - | Tmeta _ | Tvar' _ -> assert false - | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) - | Tglob (r,[]) -> pp_global Type r - | Tglob (r,l) -> - if r = IndRef (kn_sig,0) then - pp_type true vl (List.hd l) - else - pp_par par - (pp_global Type r ++ spc () ++ - prlist_with_sep spc (pp_type true vl) l) - | Tarr (t1,t2) -> - pp_par par - (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy _ -> str "()" - | Tunknown -> str "()" - | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" - in - hov 0 (pp_rec par t) - -(*s Pretty-printing of expressions. [par] indicates whether - parentheses are needed or not. [env] is the list of names for the - de Bruijn variables. [args] is the list of collected arguments - (already pretty-printed). *) - -let expr_needs_par = function - | MLlam _ -> true - | MLcase _ -> true - | _ -> false - - -let rec pp_expr par env args = - let par' = args <> [] || par - and apply st = pp_apply st par args in - function - | MLrel n -> - let id = get_db_name n env in apply (pr_id id) - | MLapp (f,args') -> - let stl = List.map (pp_expr true env []) args' in - pp_expr par env (stl @ args) f - | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl,env' = push_vars fl env in - let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in - apply (pp_par par' st) - | MLletin (id,a1,a2) -> - let i,env' = push_vars [id] env in - let pp_id = pr_id (List.hd i) - and pp_a1 = pp_expr false env [] a1 - and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in - hv 0 - (apply - (pp_par par' - (hv 0 - (hov 5 - (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ - spc () ++ str "in") ++ - spc () ++ hov 0 pp_a2))) - | MLglob r -> - apply (pp_global Term r) - | MLcons (_,r,[]) -> - assert (args=[]); pp_global Cons r - | MLcons (_,r,[a]) -> - assert (args=[]); - pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) - | MLcons (_,r,args') -> - assert (args=[]); - pp_par par (pp_global Cons r ++ spc () ++ - prlist_with_sep spc (pp_expr true env []) args') - | MLcase ((_,factors),t, pv) -> - apply (pp_par par' - (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++ - fnl () ++ str " " ++ pp_pat env factors pv))) - | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix par env' i (Array.of_list (List.rev ids'),defs) args - | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - pp_par par (str "Prelude.error" ++ spc () ++ qs s) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) - | MLmagic a -> - pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) - | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") - -and pp_pat env factors pv = - let pp_one_pat (name,ids,t) = - let ids,env' = push_vars (List.rev ids) env in - let par = expr_needs_par t in - hov 2 (pp_global Cons name ++ - (match ids with - | [] -> mt () - | _ -> (str " " ++ - prlist_with_sep - (fun () -> (spc ())) pr_id (List.rev ids))) ++ - str " ->" ++ spc () ++ pp_expr par env' [] t) - in - prvecti - (fun i x -> if List.mem i factors then mt () else - (pp_one_pat pv.(i) ++ - if factors = [] && i = Array.length pv - 1 then mt () - else fnl () ++ str " ")) pv - ++ - match factors with - | [] -> mt () - | i::_ -> - let (_,ids,t) = pv.(i) in - let t = ast_lift (-List.length ids) t in - hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t) - -(*s names of the functions ([ids]) are already pushed in [env], - and passed here just for convenience. *) - -and pp_fix par env i (ids,bl) args = - pp_par par - (v 0 - (v 2 (str "let" ++ fnl () ++ - prvect_with_sep fnl - (fun (fi,ti) -> pp_function env (pr_id fi) ti) - (array_map2 (fun a b -> a,b) ids bl)) ++ - fnl () ++ - hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) - -and pp_function env f t = - let bl,t' = collect_lams t in - let bl,env' = push_vars bl env in - (f ++ pr_binding (List.rev bl) ++ - str " =" ++ fnl () ++ str " " ++ - hov 2 (pp_expr false env' [] t')) - -(*s Pretty-printing of inductive types declaration. *) - -let pp_comment s = str "-- " ++ s ++ fnl () - -let pp_logical_ind packet = - pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ - pp_comment (str "with constructors : " ++ - prvect_with_sep spc pr_id packet.ip_consnames) - -let pp_singleton kn packet = - let l = rename_tvars keywords packet.ip_vars in - let l' = List.rev l in - hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ - prlist_with_sep spc pr_id l ++ - (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++ - pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ - pp_comment (str "singleton inductive, whose constructor was " ++ - pr_id packet.ip_consnames.(0))) - -let pp_one_ind ip pl cv = - let pl = rename_tvars keywords pl in - let pp_constructor (r,l) = - (pp_global Cons r ++ - match l with - | [] -> (mt ()) - | _ -> (str " " ++ - prlist_with_sep - (fun () -> (str " ")) (pp_type true pl) l)) - in - str (if Array.length cv = 0 then "type " else "data ") ++ - pp_global Type (IndRef ip) ++ str " " ++ - prlist_with_sep (fun () -> str " ") pr_lower_id pl ++ - (if pl = [] then mt () else str " ") ++ - if Array.length cv = 0 then str "= () -- empty inductive" - else - (v 0 (str "= " ++ - prvect_with_sep (fun () -> fnl () ++ str " | ") pp_constructor - (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) - -let rec pp_ind first kn i ind = - if i >= Array.length ind.ind_packets then - if first then mt () else fnl () - else - let ip = (kn,i) in - let p = ind.ind_packets.(i) in - if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind - else - if p.ip_logical then - pp_logical_ind p ++ pp_ind first kn (i+1) ind - else - pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ - pp_ind false kn (i+1) ind - - -(*s Pretty-printing of a declaration. *) - -let pp_string_parameters ids = prlist (fun id -> str id ++ str " ") - -let pp_decl = function - | Dind (kn,i) when i.ind_info = Singleton -> - pp_singleton kn i.ind_packets.(0) ++ fnl () - | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) - | Dtype (r, l, t) -> - if is_inline_custom r then mt () - else - let l = rename_tvars keywords l in - let st = - try - let ids,s = find_type_custom r in - prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s - with not_found -> - prlist (fun id -> pr_id id ++ str " ") l ++ - if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n" - else str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () - | Dfix (rv, defs, typs) -> - let max = Array.length rv in - let rec iter i = - if i = max then mt () - else - let e = pp_global Term rv.(i) in - e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () - ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 () - ++ iter (i+1) - in iter 0 - | Dterm (r, a, t) -> - if is_inline_custom r then mt () - else - let e = pp_global Term r in - e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ - if is_custom r then - hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) - else - hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) - -let pp_structure_elem = function - | (l,SEdecl d) -> pp_decl d - | (l,SEmodule m) -> - failwith "TODO: Haskell extraction of modules not implemented yet" - | (l,SEmodtype m) -> - failwith "TODO: Haskell extraction of modules not implemented yet" - -let pp_struct = - let pp_sel (mp,sel) = - push_visible mp None; - let p = prlist_strict pp_structure_elem sel in - pop_visible (); p - in - prlist_strict pp_sel - - -let haskell_descr = { - keywords = keywords; - file_suffix = ".hs"; - capital_file = true; - preamble = preamble; - pp_struct = pp_struct; - sig_suffix = None; - sig_preamble = (fun _ _ _ -> mt ()); - pp_sig = (fun _ -> mt ()); - pp_decl = pp_decl; -} diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli deleted file mode 100644 index 1af9c231..00000000 --- a/contrib/extraction/haskell.mli +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) - -val haskell_descr : Miniml.language_descr - diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli deleted file mode 100644 index dfe4eb48..00000000 --- a/contrib/extraction/miniml.mli +++ /dev/null @@ -1,188 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*) - -(*s Target language for extraction: a core ML called MiniML. *) - -open Pp -open Util -open Names -open Libnames - -(* The [signature] type is used to know how many arguments a CIC - object expects, and what these arguments will become in the ML - object. *) - -(* We eliminate from terms: 1) types 2) logical parts. - [Kother] stands both for logical or unknown reason. *) - -type kill_reason = Ktype | Kother - -type sign = Keep | Kill of kill_reason - - -(* Convention: outmost lambda/product gives the head of the list. *) - -type signature = sign list - -(*s ML type expressions. *) - -type ml_type = - | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list - | Tvar of int - | Tvar' of int (* same as Tvar, used to avoid clash *) - | Tmeta of ml_meta (* used during ML type reconstruction *) - | Tdummy of kill_reason - | Tunknown - | Taxiom - -and ml_meta = { id : int; mutable contents : ml_type option } - -(* ML type schema. - The integer is the number of variable in the schema. *) - -type ml_schema = int * ml_type - -(*s ML inductive types. *) - -type inductive_info = - | Singleton - | Coinductive - | Standard - | Record of global_reference list - -type case_info = int list (* list of branches to merge in a _ pattern *) - -(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. - If the inductive is logical ([ip_logical = false]), then all other fields - are unused. Otherwise, - [ip_sign] is a signature concerning the arguments of the inductive, - [ip_vars] contains the names of the type variables surviving in ML, - [ip_types] contains the ML types of all constructors. -*) - -type ml_ind_packet = { - ip_typename : identifier; - ip_consnames : identifier array; - ip_logical : bool; - ip_sign : signature; - ip_vars : identifier list; - ip_types : (ml_type list) array } - -(* [ip_nparams] contains the number of parameters. *) - -type equiv = - | NoEquiv - | Equiv of kernel_name - | RenEquiv of string - -type ml_ind = { - ind_info : inductive_info; - ind_nparams : int; - ind_packets : ml_ind_packet array; - ind_equiv : equiv -} - -(*s ML terms. *) - -type ml_ast = - | MLrel of int - | MLapp of ml_ast * ml_ast list - | MLlam of identifier * ml_ast - | MLletin of identifier * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of inductive_info * global_reference * ml_ast list - | MLcase of (inductive_info*case_info) * ml_ast * - (global_reference * identifier list * ml_ast) array - | MLfix of int * identifier array * ml_ast array - | MLexn of string - | MLdummy - | MLaxiom - | MLmagic of ml_ast - -(*s ML declarations. *) - -type ml_decl = - | Dind of kernel_name * ml_ind - | Dtype of global_reference * identifier list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array - -type ml_spec = - | Sind of kernel_name * ml_ind - | Stype of global_reference * identifier list * ml_type option - | Sval of global_reference * ml_type - -type ml_specif = - | Spec of ml_spec - | Smodule of ml_module_type - | Smodtype of ml_module_type - -and ml_module_type = - | MTident of module_path - | MTfunsig of mod_bound_id * ml_module_type * ml_module_type - | MTsig of mod_self_id * ml_module_sig - | MTwith of ml_module_type * ml_with_declaration - -and ml_with_declaration = - | ML_With_type of identifier list * identifier list * ml_type - | ML_With_module of identifier list * module_path - -and ml_module_sig = (label * ml_specif) list - -type ml_structure_elem = - | SEdecl of ml_decl - | SEmodule of ml_module - | SEmodtype of ml_module_type - -and ml_module_expr = - | MEident of module_path - | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr - | MEstruct of mod_self_id * ml_module_structure - | MEapply of ml_module_expr * ml_module_expr - -and ml_module_structure = (label * ml_structure_elem) list - -and ml_module = - { ml_mod_expr : ml_module_expr; - ml_mod_type : ml_module_type } - -(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] - implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *) - -type ml_structure = (module_path * ml_module_structure) list - -type ml_signature = (module_path * ml_module_sig) list - -type unsafe_needs = { - mldummy : bool; - tdummy : bool; - tunknown : bool; - magic : bool -} - -type language_descr = { - keywords : Idset.t; - - (* Concerning the source file *) - file_suffix : string; - capital_file : bool; (* should we capitalize filenames ? *) - preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; - pp_struct : ml_structure -> std_ppcmds; - - (* Concerning a possible interface file *) - sig_suffix : string option; - sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds; - pp_sig : ml_signature -> std_ppcmds; - - (* for an isolated declaration print *) - pp_decl : ml_decl -> std_ppcmds; - -} diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml deleted file mode 100644 index 4e2904ba..00000000 --- a/contrib/extraction/mlutil.ml +++ /dev/null @@ -1,1167 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: mlutil.ml 13202 2010-06-25 22:36:30Z letouzey $ i*) - -(*i*) -open Pp -open Util -open Names -open Libnames -open Nametab -open Table -open Miniml -(*i*) - -(*s Exceptions. *) - -exception Found -exception Impossible - -(*S Names operations. *) - -let anonymous = id_of_string "x" -let dummy_name = id_of_string "_" - -let id_of_name = function - | Anonymous -> anonymous - | Name id when id = dummy_name -> anonymous - | Name id -> id - -(*S Operations upon ML types (with meta). *) - -let meta_count = ref 0 - -let reset_meta_count () = meta_count := 0 - -let new_meta _ = - incr meta_count; - Tmeta {id = !meta_count; contents = None} - -(*s Sustitution of [Tvar i] by [t] in a ML type. *) - -let type_subst i t0 t = - let rec subst t = match t with - | Tvar j when i = j -> t0 - | Tmeta {contents=None} -> t - | Tmeta {contents=Some u} -> subst u - | Tarr (a,b) -> Tarr (subst a, subst b) - | Tglob (r, l) -> Tglob (r, List.map subst l) - | a -> a - in subst t - -(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) - -let type_subst_list l t = - let rec subst t = match t with - | Tvar j -> List.nth l (j-1) - | Tmeta {contents=None} -> t - | Tmeta {contents=Some u} -> subst u - | Tarr (a,b) -> Tarr (subst a, subst b) - | Tglob (r, l) -> Tglob (r, List.map subst l) - | a -> a - in subst t - -(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *) - -let type_subst_vect v t = - let rec subst t = match t with - | Tvar j -> v.(j-1) - | Tmeta {contents=None} -> t - | Tmeta {contents=Some u} -> subst u - | Tarr (a,b) -> Tarr (subst a, subst b) - | Tglob (r, l) -> Tglob (r, List.map subst l) - | a -> a - in subst t - -(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *) - -let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t - -(*s Occur-check of a free meta in a type *) - -let rec type_occurs alpha t = - match t with - | Tmeta {id=beta; contents=None} -> alpha = beta - | Tmeta {contents=Some u} -> type_occurs alpha u - | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 - | Tglob (r,l) -> List.exists (type_occurs alpha) l - | _ -> false - -(*s Most General Unificator *) - -let rec mgu = function - | Tmeta m, Tmeta m' when m.id = m'.id -> () - | Tmeta m, t when m.contents=None -> - if type_occurs m.id t then raise Impossible - else m.contents <- Some t - | t, Tmeta m when m.contents=None -> - if type_occurs m.id t then raise Impossible - else m.contents <- Some t - | Tmeta {contents=Some u}, t -> mgu (u, t) - | t, Tmeta {contents=Some u} -> mgu (t, u) - | Tarr(a, b), Tarr(a', b') -> - mgu (a, a'); mgu (b, b') - | Tglob (r,l), Tglob (r',l') when r = r' -> - List.iter mgu (List.combine l l') - | Tvar i, Tvar j when i = j -> () - | Tvar' i, Tvar' j when i = j -> () - | Tdummy _, Tdummy _ -> () - | Tunknown, Tunknown -> () - | _ -> raise Impossible - -let needs_magic p = try mgu p; false with Impossible -> true - -let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a - -let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a - - -(*S ML type env. *) - -module Mlenv = struct - - let meta_cmp m m' = compare m.id m'.id - module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end) - - (* Main MLenv type. [env] is the real environment, whereas [free] - (tries to) record the free meta variables occurring in [env]. *) - - type t = { env : ml_schema list; mutable free : Metaset.t} - - (* Empty environment. *) - - let empty = { env = []; free = Metaset.empty } - - (* [get] returns a instantiated copy of the n-th most recently added - type in the environment. *) - - let get mle n = - assert (List.length mle.env >= n); - instantiation (List.nth mle.env (n-1)) - - (* [find_free] finds the free meta in a type. *) - - let rec find_free set = function - | Tmeta m when m.contents = None -> Metaset.add m set - | Tmeta {contents = Some t} -> find_free set t - | Tarr (a,b) -> find_free (find_free set a) b - | Tglob (_,l) -> List.fold_left find_free set l - | _ -> set - - (* The [free] set of an environment can be outdate after - some unifications. [clean_free] takes care of that. *) - - let clean_free mle = - let rem = ref Metaset.empty - and add = ref Metaset.empty in - let clean m = match m.contents with - | None -> () - | Some u -> rem := Metaset.add m !rem; add := find_free !add u - in - Metaset.iter clean mle.free; - mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add - - (* From a type to a type schema. If a [Tmeta] is still uninstantiated - and does appears in the [mle], then it becomes a [Tvar]. *) - - let generalization mle t = - let c = ref 0 in - let map = ref (Intmap.empty : int Intmap.t) in - let add_new i = incr c; map := Intmap.add i !c !map; !c in - let rec meta2var t = match t with - | Tmeta {contents=Some u} -> meta2var u - | Tmeta ({id=i} as m) -> - (try Tvar (Intmap.find i !map) - with Not_found -> - if Metaset.mem m mle.free then t - else Tvar (add_new i)) - | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) - | Tglob (r,l) -> Tglob (r, List.map meta2var l) - | t -> t - in !c, meta2var t - - (* Adding a type in an environment, after generalizing. *) - - let push_gen mle t = - clean_free mle; - { env = generalization mle t :: mle.env; free = mle.free } - - (* Adding a type with no [Tvar], hence no generalization needed. *) - - let push_type {env=e;free=f} t = - { env = (0,t) :: e; free = find_free f t} - - (* Adding a type with no [Tvar] nor [Tmeta]. *) - - let push_std_type {env=e;free=f} t = - { env = (0,t) :: e; free = f} - -end - -(*S Operations upon ML types (without meta). *) - -(*s Does a section path occur in a ML type ? *) - -let rec type_mem_kn kn = function - | Tmeta {contents = Some t} -> type_mem_kn kn t - | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l - | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b) - | _ -> false - -(*s Greatest variable occurring in [t]. *) - -let type_maxvar t = - let rec parse n = function - | Tmeta {contents = Some t} -> parse n t - | Tvar i -> max i n - | Tarr (a,b) -> parse (parse n a) b - | Tglob (_,l) -> List.fold_left parse n l - | _ -> n - in parse 0 t - -(*s From [a -> b -> c] to [[a;b],c]. *) - -let rec type_decomp = function - | Tmeta {contents = Some t} -> type_decomp t - | Tarr (a,b) -> let l,h = type_decomp b in a::l, h - | a -> [],a - -(*s The converse: From [[a;b],c] to [a -> b -> c]. *) - -let rec type_recomp (l,t) = match l with - | [] -> t - | a::l -> Tarr (a, type_recomp (l,t)) - -(*s Translating [Tvar] to [Tvar'] to avoid clash. *) - -let rec var2var' = function - | Tmeta {contents = Some t} -> var2var' t - | Tvar i -> Tvar' i - | Tarr (a,b) -> Tarr (var2var' a, var2var' b) - | Tglob (r,l) -> Tglob (r, List.map var2var' l) - | a -> a - -type abbrev_map = global_reference -> ml_type option - -(*s Delta-reduction of type constants everywhere in a ML type [t]. - [env] is a function of type [ml_type_env]. *) - -let type_expand env t = - let rec expand = function - | Tmeta {contents = Some t} -> expand t - | Tglob (r,l) -> - (match env r with - | Some mlt -> expand (type_subst_list l mlt) - | None -> Tglob (r, List.map expand l)) - | Tarr (a,b) -> Tarr (expand a, expand b) - | a -> a - in if Table.type_expand () then expand t else t - -(*s Idem, but only at the top level of implications. *) - -let is_arrow = function Tarr _ -> true | _ -> false - -let type_weak_expand env t = - let rec expand = function - | Tmeta {contents = Some t} -> expand t - | Tglob (r,l) as t -> - (match env r with - | Some mlt -> - let u = expand (type_subst_list l mlt) in - if is_arrow u then u else t - | None -> t) - | Tarr (a,b) -> Tarr (a, expand b) - | a -> a - in expand t - -(*s Generating a signature from a ML type. *) - -let type_to_sign env t = match type_expand env t with - | Tdummy d -> Kill d - | _ -> Keep - -let type_to_signature env t = - let rec f = function - | Tmeta {contents = Some t} -> f t - | Tarr (Tdummy d, b) -> Kill d :: f b - | Tarr (_, b) -> Keep :: f b - | _ -> [] - in f (type_expand env t) - -let isKill = function Kill _ -> true | _ -> false - -let isDummy = function Tdummy _ -> true | _ -> false - -let sign_of_id i = if i = dummy_name then Kill Kother else Keep - -(*s Removing [Tdummy] from the top level of a ML type. *) - -let type_expunge env t = - let s = type_to_signature env t in - if s = [] then t - else if List.mem Keep s then - let rec f t s = - if List.exists isKill s then - match t with - | Tmeta {contents = Some t} -> f t s - | Tarr (a,b) -> - let t = f b (List.tl s) in - if List.hd s = Keep then Tarr (a, t) else t - | Tglob (r,l) -> - (match env r with - | Some mlt -> f (type_subst_list l mlt) s - | None -> assert false) - | _ -> assert false - else t - in f t s - else if List.mem (Kill Kother) s then - Tarr (Tdummy Kother, snd (type_decomp (type_weak_expand env t))) - else snd (type_decomp (type_weak_expand env t)) - -(*S Generic functions over ML ast terms. *) - -(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care - of the number of bingings crossed before reaching the [MLrel]. *) - -let ast_iter_rel f = - let rec iter n = function - | MLrel i -> f (i-n) - | MLlam (_,a) -> iter (n+1) a - | MLletin (_,a,b) -> iter n a; iter (n+1) b - | MLcase (_,a,v) -> - iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v - | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v - | MLapp (a,l) -> iter n a; List.iter (iter n) l - | MLcons (_,_,l) -> List.iter (iter n) l - | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () - in iter 0 - -(*s Map over asts. *) - -let ast_map_case f (c,ids,a) = (c,ids,f a) - -let ast_map f = function - | MLlam (i,a) -> MLlam (i, f a) - | MLletin (i,a,b) -> MLletin (i, f a, f b) - | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v) - | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) - | MLapp (a,l) -> MLapp (f a, List.map f l) - | MLcons (i,c,l) -> MLcons (i,c, List.map f l) - | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a - -(*s Map over asts, with binding depth as parameter. *) - -let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a) - -let ast_map_lift f n = function - | MLlam (i,a) -> MLlam (i, f (n+1) a) - | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) - | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v) - | MLfix (i,ids,v) -> - let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) - | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) - | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l) - | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a - -(*s Iter over asts. *) - -let ast_iter_case f (c,ids,a) = f a - -let ast_iter f = function - | MLlam (i,a) -> f a - | MLletin (i,a,b) -> f a; f b - | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v - | MLfix (i,ids,v) -> Array.iter f v - | MLapp (a,l) -> f a; List.iter f l - | MLcons (_,c,l) -> List.iter f l - | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () - -(*S Operations concerning De Bruijn indices. *) - -(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *) - -let ast_occurs k t = - try - ast_iter_rel (fun i -> if i = k then raise Found) t; false - with Found -> true - -(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] - in [t] with [k<=i<=k'] *) - -let ast_occurs_itvl k k' t = - try - ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false - with Found -> true - -(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *) - -let nb_occur_k k t = - let cpt = ref 0 in - ast_iter_rel (fun i -> if i = k then incr cpt) t; - !cpt - -let nb_occur t = nb_occur_k 1 t - -(* Number of occurences of [Rel 1] in [t], with special treatment of match: - occurences in different branches aren't added, but we rather use max. *) - -let nb_occur_match = - let rec nb k = function - | MLrel i -> if i = k then 1 else 0 - | MLcase(_,a,v) -> - (nb k a) + - Array.fold_left - (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v - | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) - | MLfix (_,ids,v) -> let k = k+(Array.length ids) in - Array.fold_left (fun r a -> r+(nb k a)) 0 v - | MLlam (_,a) -> nb (k+1) a - | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l - | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l - | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 - in nb 1 - -(*s Lifting on terms. - [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) - -let ast_lift k t = - let rec liftrec n = function - | MLrel i as a -> if i-n < 1 then a else MLrel (i+k) - | a -> ast_map_lift liftrec n a - in if k = 0 then t else liftrec 0 t - -let ast_pop t = ast_lift (-1) t - -(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... - Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *) - -let permut_rels k k' = - let rec permut n = function - | MLrel i as a -> - let i' = i-n in - if i'<1 || i'>k+k' then a - else if i'<=k then MLrel (i+k') - else MLrel (i-k) - | a -> ast_map_lift permut n a - in permut 0 - -(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. - Lifting (of one binder) is done at the same time. *) - -let ast_subst e = - let rec subst n = function - | MLrel i as a -> - let i' = i-n in - if i'=1 then ast_lift n e - else if i'<1 then a - else MLrel (i-1) - | a -> ast_map_lift subst n a - in subst 0 - -(*s Generalized substitution. - [gen_subst v d t] applies to [t] the substitution coded in the - [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies - to [Rel] greater than [Array.length v]. *) - -let gen_subst v d t = - let rec subst n = function - | MLrel i as a -> - let i'= i-n in - if i' < 1 then a - else if i' <= Array.length v then - ast_lift n v.(i'-1) - else MLrel (i+d) - | a -> ast_map_lift subst n a - in subst 0 t - -(*S Operations concerning lambdas. *) - -(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns - [[idn;...;id1]] and the term [t]. *) - -let collect_lams = - let rec collect acc = function - | MLlam(id,t) -> collect (id::acc) t - | x -> acc,x - in collect [] - -(*s [collect_n_lams] does the same for a precise number of [MLlam]. *) - -let collect_n_lams = - let rec collect acc n t = - if n = 0 then acc,t - else match t with - | MLlam(id,t) -> collect (id::acc) (n-1) t - | _ -> assert false - in collect [] - -(*s [remove_n_lams] just removes some [MLlam]. *) - -let rec remove_n_lams n t = - if n = 0 then t - else match t with - | MLlam(_,t) -> remove_n_lams (n-1) t - | _ -> assert false - -(*s [nb_lams] gives the number of head [MLlam]. *) - -let rec nb_lams = function - | MLlam(_,t) -> succ (nb_lams t) - | _ -> 0 - -(*s [named_lams] does the converse of [collect_lams]. *) - -let rec named_lams ids a = match ids with - | [] -> a - | id :: ids -> named_lams ids (MLlam (id,a)) - -(*s The same in anonymous version. *) - -let rec anonym_lams a = function - | 0 -> a - | n -> anonym_lams (MLlam (anonymous,a)) (pred n) - -(*s Idem for [dummy_name]. *) - -let rec dummy_lams a = function - | 0 -> a - | n -> dummy_lams (MLlam (dummy_name,a)) (pred n) - -(*s mixed according to a signature. *) - -let rec anonym_or_dummy_lams a = function - | [] -> a - | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) - | Kill _ :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s) - -(*S Operations concerning eta. *) - -(*s The following function creates [MLrel n;...;MLrel 1] *) - -let rec eta_args n = - if n = 0 then [] else (MLrel n)::(eta_args (pred n)) - -(*s Same, but filtered by a signature. *) - -let rec eta_args_sign n = function - | [] -> [] - | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) - | Kill _ :: s -> eta_args_sign (n-1) s - -(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) - -let rec test_eta_args_lift k n = function - | [] -> n=0 - | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q) - -(*s Computes an eta-reduction. *) - -let eta_red e = - let ids,t = collect_lams e in - let n = List.length ids in - if n = 0 then e - else match t with - | MLapp (f,a) -> - let m = List.length a in - let ids,body,args = - if m = n then - [], f, a - else if m < n then - list_skipn m ids, f, a - else (* m > n *) - let a1,a2 = list_chop (m-n) a in - [], MLapp (f,a1), a2 - in - let p = List.length args in - if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) - then named_lams ids (ast_lift (-p) body) - else e - | _ -> e - -(*s Computes all head linear beta-reductions possible in [(t a)]. - Non-linear head beta-redex become let-in. *) - -let rec linear_beta_red a t = match a,t with - | [], _ -> t - | a0::a, MLlam (id,t) -> - (match nb_occur_match t with - | 0 -> linear_beta_red a (ast_pop t) - | 1 -> linear_beta_red a (ast_subst a0 t) - | _ -> - let a = List.map (ast_lift 1) a in - MLletin (id, a0, linear_beta_red a t)) - | _ -> MLapp (t, a) - -(*s Applies a substitution [s] of constants by their body, plus - linear beta reductions at modified positions. *) - -let rec ast_glob_subst s t = match t with - | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> - let a = List.map (ast_glob_subst s) a in - (try linear_beta_red a (Refmap.find refe s) - with Not_found -> MLapp (f, a)) - | MLglob ((ConstRef kn) as refe) -> - (try Refmap.find refe s with Not_found -> t) - | _ -> ast_map (ast_glob_subst s) t - - -(*S Auxiliary functions used in simplification of ML cases. *) - -(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1] - and raises [Impossible] if any variable in [l] occurs outside such a - [MLcons] *) - -let check_and_generalize (r0,l,c) = - let nargs = List.length l in - let rec genrec n = function - | MLrel i as c -> - let i' = i-n in - if i'<1 then c - else if i'>nargs then MLrel (i-nargs+1) - else raise Impossible - | MLcons(_,r,args) when r=r0 && (test_eta_args_lift n nargs args) -> - MLrel (n+1) - | a -> ast_map_lift genrec n a - in genrec 0 c - -(*s [check_generalizable_case] checks if all branches can be seen as the - same function [f] applied to the term matched. It is a generalized version - of the identity case optimization. *) - -(* CAVEAT: this optimization breaks typing in some special case. example: - [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a], - which is incompatible with the type of [let f x = x]. - By default, we brutally disable this optim except for some known types: - [bool], [sumbool], [sumor] *) - -let generalizable_list = - let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes") - and specif = MPfile (dirpath_of_string "Coq.Init.Specif") - in - [ make_kn datatypes empty_dirpath (mk_label "bool"); - make_kn specif empty_dirpath (mk_label "sumbool"); - make_kn specif empty_dirpath (mk_label "sumor") ] - -let check_generalizable_case unsafe br = - if not unsafe then - (match br.(0) with - | ConstructRef ((kn,_),_), _, _ -> - if not (List.mem kn generalizable_list) then raise Impossible - | _ -> assert false); - let f = check_and_generalize br.(0) in - for i = 1 to Array.length br - 1 do - if check_and_generalize br.(i) <> f then raise Impossible - done; f - -(*s Detecting similar branches of a match *) - -(* If several branches of a match are equal (and independent from their - patterns) we will print them using a _ pattern. If _all_ branches - are equal, we remove the match. -*) - -let common_branches br = - let tab = Hashtbl.create 13 in - for i = 0 to Array.length br - 1 do - let (r,ids,t) = br.(i) in - let n = List.length ids in - if not (ast_occurs_itvl 1 n t) then - let t = ast_lift (-n) t in - let l = try Hashtbl.find tab t with Not_found -> [] in - Hashtbl.replace tab t (i::l) - done; - let best = ref [] in - Hashtbl.iter - (fun _ l -> if List.length l > List.length !best then best := l) tab; - if List.length !best < 2 then [] else !best - -(*s If all branches are functions, try to permut the case and the functions. *) - -let rec merge_ids ids ids' = match ids,ids' with - | [],l -> l - | l,[] -> l - | i::ids, i'::ids' -> - (if i = dummy_name then i' else i) :: (merge_ids ids ids') - -let is_exn = function MLexn _ -> true | _ -> false - -let rec permut_case_fun br acc = - let nb = ref max_int in - Array.iter (fun (_,_,t) -> - let ids, c = collect_lams t in - let n = List.length ids in - if (n < !nb) && (not (is_exn c)) then nb := n) br; - if !nb = max_int || !nb = 0 then ([],br) - else begin - let br = Array.copy br in - let ids = ref [] in - for i = 0 to Array.length br - 1 do - let (r,l,t) = br.(i) in - let local_nb = nb_lams t in - if local_nb < !nb then (* t = MLexn ... *) - br.(i) <- (r,l,remove_n_lams local_nb t) - else begin - let local_ids,t = collect_n_lams !nb t in - ids := merge_ids !ids local_ids; - br.(i) <- (r,l,permut_rels !nb (List.length l) t) - end - done; - (!ids,br) - end - -(*S Generalized iota-reduction. *) - -(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] - with [(is_iota_gen e)=true]. Any generalized iota-redex is - transformed into beta-redexes. *) - -let rec is_iota_gen = function - | MLcons _ -> true - | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br - | _ -> false - -let constructor_index = function - | ConstructRef (_,j) -> pred j - | _ -> assert false - -let iota_gen br = - let rec iota k = function - | MLcons (i,r,a) -> - let (_,ids,c) = br.(constructor_index r) in - let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in - let c = ast_lift k c in - MLapp (c,a) - | MLcase(i,e,br') -> - let new_br = - Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br' - in MLcase(i,e, new_br) - | _ -> assert false - in iota 0 - -let is_atomic = function - | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true - | _ -> false - -(*S The main simplification function. *) - -(* Some beta-iota reductions + simplifications. *) - -let rec simpl o = function - | MLapp (f, []) -> - simpl o f - | MLapp (f, a) -> - simpl_app o (List.map (simpl o) a) (simpl o f) - | MLcase (i,e,br) -> - let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in - simpl_case o i br (simpl o e) - | MLletin(id,c,e) -> - let e = (simpl o e) in - if - (id = dummy_name) || (is_atomic c) || (is_atomic e) || - (let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let)) - then - simpl o (ast_subst c e) - else - MLletin(id, simpl o c, e) - | MLfix(i,ids,c) -> - let n = Array.length ids in - if ast_occurs_itvl 1 n c.(i) then - MLfix (i, ids, Array.map (simpl o) c) - else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) - | a -> ast_map (simpl o) a - -and simpl_app o a = function - | MLapp (f',a') -> simpl_app o (a'@a) f' - | MLlam (id,t) when id = dummy_name -> - simpl o (MLapp (ast_pop t, List.tl a)) - | MLlam (id,t) -> (* Beta redex *) - (match nb_occur_match t with - | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) - | 1 when o.opt_lin_beta -> - simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) - | _ -> - let a' = List.map (ast_lift 1) (List.tl a) in - simpl o (MLletin (id, List.hd a, MLapp (t, a')))) - | MLletin (id,e1,e2) when o.opt_let_app -> - (* Application of a letin: we push arguments inside *) - MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) - | MLcase (i,e,br) when o.opt_case_app -> - (* Application of a case: we push arguments inside *) - let br' = - Array.map - (fun (n,l,t) -> - let k = List.length l in - let a' = List.map (ast_lift k) a in - (n, l, simpl o (MLapp (t,a')))) br - in simpl o (MLcase (i,e,br')) - | (MLdummy | MLexn _) as e -> e - (* We just discard arguments in those cases. *) - | f -> MLapp (f,a) - -and simpl_case o i br e = - if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *) - simpl o (iota_gen br e) - else - try (* Does a term [f] exist such that each branch is [(f e)] ? *) - if not o.opt_case_idr then raise Impossible; - let f = check_generalizable_case o.opt_case_idg br in - simpl o (MLapp (MLlam (anonymous,f),[e])) - with Impossible -> - (* Detect common branches *) - let common_br = if not o.opt_case_cst then [] else common_branches br in - if List.length common_br = Array.length br && br <> [||] then - let (_,ids,t) = br.(0) in ast_lift (-List.length ids) t - else - let new_i = (fst i, common_br) in - (* Swap the case and the lam if possible *) - if o.opt_case_fun - then - let ids,br = permut_case_fun br [] in - let n = List.length ids in - if n <> 0 then named_lams ids (MLcase (new_i,ast_lift n e, br)) - else MLcase (new_i,e,br) - else MLcase (new_i,e,br) - -let rec post_simpl = function - | MLletin(_,c,e) when (is_atomic (eta_red c)) -> - post_simpl (ast_subst (eta_red c) e) - | a -> ast_map post_simpl a - -(*S Local prop elimination. *) -(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) - -(*s In a list, it selects only the elements corresponding to a [Keep] - in the boolean list [l]. *) - -let rec select_via_bl l args = match l,args with - | [],_ -> args - | Keep::l,a::args -> a :: (select_via_bl l args) - | Kill _::l,a::args -> select_via_bl l args - | _ -> assert false - -(*s [kill_some_lams] removes some head lambdas according to the signature [bl]. - This list is build on the identifier list model: outermost lambda - is on the right. - [Rels] corresponding to removed lambdas are supposed not to occur, and - the other [Rels] are made correct via a [gen_subst]. - Output is not directly a [ml_ast], compose with [named_lams] if needed. *) - -let kill_some_lams bl (ids,c) = - let n = List.length bl in - let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in - if n = n' then ids,c - else if n' = 0 then [],ast_lift (-n) c - else begin - let v = Array.make n MLdummy in - let rec parse_ids i j = function - | [] -> () - | Keep :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l - | Kill _ :: l -> parse_ids (i+1) j l - in parse_ids 0 1 bl ; - select_via_bl bl ids, gen_subst v (n'-n) c - end - -(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding - to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or - if there is no lambda left at all. *) - -let kill_dummy_lams c = - let ids,c = collect_lams c in - let bl = List.map sign_of_id ids in - if (List.mem Keep bl) && (List.exists isKill bl) then - let ids',c = kill_some_lams bl (ids,c) in - ids, named_lams ids' c - else raise Impossible - -(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] - and a signature [s] and builds a eta-long version. *) - -(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is : - [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) - -let eta_expansion_sign s (ids,c) = - let rec abs ids rels i = function - | [] -> - let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels - in ids, MLapp (ast_lift (i-1) c, a) - | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | Kill _ :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l - in abs ids [] 1 s - -(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] - in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [Del] in [s]. *) - -let case_expunge s e = - let m = List.length s in - let n = nb_lams e in - let p = if m <= n then collect_n_lams m e - else eta_expansion_sign (list_skipn n s) (collect_lams e) in - kill_some_lams (List.rev s) p - -(*s [term_expunge] takes a function [fun idn ... id1 -> c] - and a signature [s] and remove dummy lams. The difference - with [case_expunge] is that we here leave one dummy lambda - if all lambdas are logical dummy. *) - -let term_expunge s (ids,c) = - if s = [] then c - else - let ids,c = kill_some_lams (List.rev s) (ids,c) in - if ids = [] && List.mem (Kill Kother) s then - MLlam (dummy_name, ast_lift 1 c) - else named_lams ids c - -(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and - purge the args of [t0] corresponding to a [dummy_name]. - It makes eta-expansion if needed. *) - -let kill_dummy_args ids t0 t = - let m = List.length ids in - let bl = List.rev_map sign_of_id ids in - let rec killrec n = function - | MLapp(e, a) when e = ast_lift n t0 -> - let k = max 0 (m - (List.length a)) in - let a = List.map (killrec n) a in - let a = List.map (ast_lift k) a in - let a = select_via_bl bl (a @ (eta_args k)) in - named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) - | e when e = ast_lift n t0 -> - let a = select_via_bl bl (eta_args m) in - named_lams ids (MLapp (ast_lift m e, a)) - | e -> ast_map_lift killrec n e - in killrec 0 t - -(*s The main function for local [dummy] elimination. *) - -let rec kill_dummy = function - | MLfix(i,fi,c) -> - (try - let ids,c = kill_dummy_fix i fi c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1)) - with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) - | MLapp (MLfix (i,fi,c),a) -> - (try - let ids,c = kill_dummy_fix i fi c in - let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in - let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in - ast_subst (MLfix (i,fi,c)) e - with Impossible -> - MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a)) - | MLletin(id, MLfix (i,fi,c),e) -> - (try - let ids,c = kill_dummy_fix i fi c in - let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in - MLletin(id, MLfix(i,fi,c),e) - with Impossible -> - MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) - | MLletin(id,c,e) -> - (try - let ids,c = kill_dummy_lams c in - let e = kill_dummy_args ids (MLrel 1) e in - MLletin (id, kill_dummy c,kill_dummy e) - with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) - | a -> ast_map kill_dummy a - -and kill_dummy_fix i fi c = - let n = Array.length fi in - let ids,ci = kill_dummy_lams c.(i) in - let c = Array.copy c in c.(i) <- ci; - for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) - done; - ids,c - -(*s Putting things together. *) - -let normalize a = - let o = optims () in - let a = simpl o a in - if o.opt_kill_dum then post_simpl (kill_dummy a) else a - -(*S Special treatment of fixpoint for pretty-printing purpose. *) - -let general_optimize_fix f ids n args m c = - let v = Array.make n 0 in - for i=0 to (n-1) do v.(i)<-i done; - let aux i = function - | MLrel j when v.(j-1)>=0 -> - if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) - | _ -> raise Impossible - in list_iter_i aux args; - let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in - let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in - let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in - MLfix(0,[|f|],[|new_c|]) - -let optimize_fix a = - if not (optims()).opt_fix_fun then a - else - let ids,a' = collect_lams a in - let n = List.length ids in - if n = 0 then a - else match a' with - | MLfix(_,[|f|],[|c|]) -> - let new_f = MLapp (MLrel (n+1),eta_args n) in - let new_c = named_lams ids (normalize (ast_subst new_f c)) - in MLfix(0,[|f|],[|new_c|]) - | MLapp(a',args) -> - let m = List.length args in - (match a' with - | MLfix(_,_,_) when - (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') - -> a' - | MLfix(_,[|f|],[|c|]) -> - (try general_optimize_fix f ids n args m c - with Impossible -> a) - | _ -> a) - | _ -> a - -(*S Inlining. *) - -(* Utility functions used in the decision of inlining. *) - -let rec ml_size = function - | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l - | MLlam(_,t) -> 1 + ml_size t - | MLcons(_,_,l) -> ml_size_list l - | MLcase(_,t,pv) -> - 1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0) - | MLfix(_,_,f) -> ml_size_array f - | MLletin (_,_,t) -> ml_size t - | MLmagic t -> ml_size t - | _ -> 0 - -and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l - -and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l - -let is_fix = function MLfix _ -> true | _ -> false - -let rec is_constr = function - | MLcons _ -> true - | MLlam(_,t) -> is_constr t - | _ -> false - -(*s Strictness *) - -(* A variable is strict if the evaluation of the whole term implies - the evaluation of this variable. Non-strict variables can be found - behind Match, for example. Expanding a term [t] is a good idea when - it begins by at least one non-strict lambda, since the corresponding - argument to [t] might be unevaluated in the expanded code. *) - -exception Toplevel - -let lift n l = List.map ((+) n) l - -let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l - -(* This function returns a list of de Bruijn indices of non-strict variables, - or raises [Toplevel] if it has an internal non-strict variable. - In fact, not all variables are checked for strictness, only the ones which - de Bruijn index is in the candidates list [cand]. The flag [add] controls - the behaviour when going through a lambda: should we add the corresponding - variable to the candidates? We use this flag to check only the external - lambdas, those that will correspond to arguments. *) - -let rec non_stricts add cand = function - | MLlam (id,t) -> - let cand = lift 1 cand in - let cand = if add then 1::cand else cand in - pop 1 (non_stricts add cand t) - | MLrel n -> - List.filter ((<>) n) cand - | MLapp (MLrel n, _) -> - List.filter ((<>) n) cand - (* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *) - (* gain something if x is replaced by a function like a projection *) - | MLapp (t,l)-> - let cand = non_stricts false cand t in - List.fold_left (non_stricts false) cand l - | MLcons (_,_,l) -> - List.fold_left (non_stricts false) cand l - | MLletin (_,t1,t2) -> - let cand = non_stricts false cand t1 in - pop 1 (non_stricts add (lift 1 cand) t2) - | MLfix (_,i,f)-> - let n = Array.length i in - let cand = lift n cand in - let cand = Array.fold_left (non_stricts false) cand f in - pop n cand - | MLcase (_,t,v) -> - (* The only interesting case: for a variable to be non-strict, *) - (* it is sufficient that it appears non-strict in at least one branch, *) - (* so we make an union (in fact a merge). *) - let cand = non_stricts false cand t in - Array.fold_left - (fun c (_,i,t)-> - let n = List.length i in - let cand = lift n cand in - let cand = pop n (non_stricts add cand t) in - Sort.merge (<=) cand c) [] v - (* [merge] may duplicates some indices, but I don't mind. *) - | MLmagic t -> - non_stricts add cand t - | _ -> - cand - -(* The real test: we are looking for internal non-strict variables, so we start - with no candidates, and the only positive answer is via the [Toplevel] - exception. *) - -let is_not_strict t = - try let _ = non_stricts true [] t in false - with Toplevel -> true - -(*s Inlining decision *) - -(* [inline_test] answers the following question: - If we could inline [t] (the user said nothing special), - should we inline ? - - We expand small terms with at least one non-strict - variable (i.e. a variable that may not be evaluated). - - Futhermore we don't expand fixpoints. *) - -let inline_test t = - let t1 = eta_red t in - let t2 = snd (collect_lams t1) in - not (is_fix t2) && ml_size t < 12 && is_not_strict t - -let manual_inline_list = - let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in - List.map (fun s -> (make_con mp empty_dirpath (mk_label s))) - [ "well_founded_induction_type"; "well_founded_induction"; - "Acc_rect"; "Acc_rec" ; "Acc_iter" ; "Fix" ] - -let manual_inline = function - | ConstRef c -> List.mem c manual_inline_list - | _ -> false - -(* If the user doesn't say he wants to keep [t], we inline in two cases: - \begin{itemize} - \item the user explicitly requests it - \item [expansion_test] answers that the inlining is a good idea, and - we are free to act (AutoInline is set) - \end{itemize} *) - -let inline r t = - not (to_keep r) (* The user DOES want to keep it *) - && not (is_inline_custom r) - && (to_inline r (* The user DOES want to inline it *) - || (auto_inline () && lang () <> Haskell && not (is_projection r) - && (is_recursor r || manual_inline r || inline_test t))) - diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli deleted file mode 100644 index a55caaf2..00000000 --- a/contrib/extraction/mlutil.mli +++ /dev/null @@ -1,113 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) - -open Util -open Names -open Term -open Libnames -open Miniml - -(*s Utility functions over ML types with meta. *) - -val reset_meta_count : unit -> unit -val new_meta : 'a -> ml_type - -val type_subst : int -> ml_type -> ml_type -> ml_type -val type_subst_list : ml_type list -> ml_type -> ml_type -val type_subst_vect : ml_type array -> ml_type -> ml_type - -val instantiation : ml_schema -> ml_type - -val needs_magic : ml_type * ml_type -> bool -val put_magic_if : bool -> ml_ast -> ml_ast -val put_magic : ml_type * ml_type -> ml_ast -> ml_ast - -(*s ML type environment. *) - -module Mlenv : sig - type t - val empty : t - - (* get the n-th more recently entered schema and instantiate it. *) - val get : t -> int -> ml_type - - (* Adding a type in an environment, after generalizing free meta *) - val push_gen : t -> ml_type -> t - - (* Adding a type with no [Tvar] *) - val push_type : t -> ml_type -> t - - (* Adding a type with no [Tvar] nor [Tmeta] *) - val push_std_type : t -> ml_type -> t -end - -(*s Utility functions over ML types without meta *) - -val type_mem_kn : kernel_name -> ml_type -> bool - -val type_maxvar : ml_type -> int - -val type_decomp : ml_type -> ml_type list * ml_type -val type_recomp : ml_type list * ml_type -> ml_type - -val var2var' : ml_type -> ml_type - -type abbrev_map = global_reference -> ml_type option - -val type_expand : abbrev_map -> ml_type -> ml_type -val type_to_sign : abbrev_map -> ml_type -> sign -val type_to_signature : abbrev_map -> ml_type -> signature -val type_expunge : abbrev_map -> ml_type -> ml_type - -val isDummy : ml_type -> bool -val isKill : sign -> bool - -val case_expunge : signature -> ml_ast -> identifier list * ml_ast -val term_expunge : signature -> identifier list * ml_ast -> ml_ast - - -(*s Special identifiers. [dummy_name] is to be used for dead code - and will be printed as [_] in concrete (Caml) code. *) - -val anonymous : identifier -val dummy_name : identifier -val id_of_name : name -> identifier - -(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns - the list [idn;...;id1] and the term [t]. *) - -val collect_lams : ml_ast -> identifier list * ml_ast -val collect_n_lams : int -> ml_ast -> identifier list * ml_ast -val nb_lams : ml_ast -> int - -val dummy_lams : ml_ast -> int -> ml_ast -val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast - -val eta_args_sign : int -> signature -> ml_ast list - -(*s Utility functions over ML terms. *) - -val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast -val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast -val ast_iter : (ml_ast -> unit) -> ml_ast -> unit -val ast_occurs : int -> ml_ast -> bool -val ast_occurs_itvl : int -> int -> ml_ast -> bool -val ast_lift : int -> ml_ast -> ml_ast -val ast_pop : ml_ast -> ml_ast -val ast_subst : ml_ast -> ml_ast -> ml_ast - -val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast - -val normalize : ml_ast -> ml_ast -val optimize_fix : ml_ast -> ml_ast -val inline : global_reference -> ml_ast -> bool - - - diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml deleted file mode 100644 index 68adeb81..00000000 --- a/contrib/extraction/modutil.ml +++ /dev/null @@ -1,365 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: modutil.ml 11602 2008-11-18 00:08:33Z letouzey $ i*) - -open Names -open Declarations -open Environ -open Libnames -open Util -open Miniml -open Table -open Mlutil -open Mod_subst - -(*S Functions upon ML modules. *) - -let rec msid_of_mt = function - | MTident mp -> begin - match Modops.eval_struct (Global.env()) (SEBident mp) with - | SEBstruct(msid,_) -> MPself msid - | _ -> anomaly "Extraction:the With can't be applied to a funsig" - end - | MTwith(mt,_)-> msid_of_mt mt - | _ -> anomaly "Extraction:the With operator isn't applied to a name" - -(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a - [ml_structure]. *) - -let struct_iter do_decl do_spec s = - let rec mt_iter = function - | MTident _ -> () - | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' - | MTwith (mt,ML_With_type(idl,l,t))-> - let mp_mt = msid_of_mt mt in - let l',idl' = list_sep_last idl in - let mp_w = - List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' - in - let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in - mt_iter mt; do_decl (Dtype(r,l,t)) - | MTwith (mt,_)->mt_iter mt - | MTsig (_, sign) -> List.iter spec_iter sign - and spec_iter = function - | (_,Spec s) -> do_spec s - | (_,Smodule mt) -> mt_iter mt - | (_,Smodtype mt) -> mt_iter mt - in - let rec se_iter = function - | (_,SEdecl d) -> do_decl d - | (_,SEmodule m) -> - me_iter m.ml_mod_expr; mt_iter m.ml_mod_type - | (_,SEmodtype m) -> mt_iter m - and me_iter = function - | MEident _ -> () - | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt - | MEapply (me,me') -> me_iter me; me_iter me' - | MEstruct (msid, sel) -> List.iter se_iter sel - in - List.iter (function (_,sel) -> List.iter se_iter sel) s - -(*s Apply some fonctions upon all references in [ml_type], [ml_ast], - [ml_decl], [ml_spec] and [ml_structure]. *) - -type do_ref = global_reference -> unit - -let record_iter_references do_term = function - | Record l -> List.iter do_term l - | _ -> () - -let type_iter_references do_type t = - let rec iter = function - | Tglob (r,l) -> do_type r; List.iter iter l - | Tarr (a,b) -> iter a; iter b - | _ -> () - in iter t - -let ast_iter_references do_term do_cons do_type a = - let rec iter a = - ast_iter iter a; - match a with - | MLglob r -> do_term r - | MLcons (i,r,_) -> - if lang () = Ocaml then record_iter_references do_term i; - do_cons r - | MLcase (i,_,v) -> - if lang () = Ocaml then record_iter_references do_term (fst i); - Array.iter (fun (r,_,_) -> do_cons r) v - | _ -> () - in iter a - -let ind_iter_references do_term do_cons do_type kn ind = - let type_iter = type_iter_references do_type in - let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in - let packet_iter ip p = - do_type (IndRef ip); - if lang () = Ocaml then - (match ind.ind_equiv with - | Equiv kne -> do_type (IndRef (kne, snd ip)); - | _ -> ()); - Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types - in - if lang () = Ocaml then record_iter_references do_term ind.ind_info; - Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets - -let decl_iter_references do_term do_cons do_type = - let type_iter = type_iter_references do_type - and ast_iter = ast_iter_references do_term do_cons do_type in - function - | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind - | Dtype (r,_,t) -> do_type r; type_iter t - | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t - | Dfix(rv,c,t) -> - Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t - -let spec_iter_references do_term do_cons do_type = function - | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind - | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot - | Sval (r,t) -> do_term r; type_iter_references do_type t - -(*s Searching occurrences of a particular term (no lifting done). *) - -exception Found - -let rec ast_search f a = - if f a then raise Found else ast_iter (ast_search f) a - -let decl_ast_search f = function - | Dterm (_,a,_) -> ast_search f a - | Dfix (_,c,_) -> Array.iter (ast_search f) c - | _ -> () - -let struct_ast_search f s = - try struct_iter (decl_ast_search f) (fun _ -> ()) s; false - with Found -> true - -let rec type_search f = function - | Tarr (a,b) -> type_search f a; type_search f b - | Tglob (r,l) -> List.iter (type_search f) l - | u -> if f u then raise Found - -let decl_type_search f = function - | Dind (_,{ind_packets=p}) -> - Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p - | Dterm (_,_,u) -> type_search f u - | Dfix (_,_,v) -> Array.iter (type_search f) v - | Dtype (_,_,u) -> type_search f u - -let spec_type_search f = function - | Sind (_,{ind_packets=p}) -> - Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p - | Stype (_,_,ot) -> Option.iter (type_search f) ot - | Sval (_,u) -> type_search f u - -let struct_type_search f s = - try struct_iter (decl_type_search f) (spec_type_search f) s; false - with Found -> true - - -(*s Generating the signature. *) - -let rec msig_of_ms = function - | [] -> [] - | (l,SEdecl (Dind (kn,i))) :: ms -> - (l,Spec (Sind (kn,i))) :: (msig_of_ms ms) - | (l,SEdecl (Dterm (r,_,t))) :: ms -> - (l,Spec (Sval (r,t))) :: (msig_of_ms ms) - | (l,SEdecl (Dtype (r,v,t))) :: ms -> - (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) - | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> - let msig = ref (msig_of_ms ms) in - for i = Array.length rv - 1 downto 0 do - msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig - done; - !msig - | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) - | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms) - -let signature_of_structure s = - List.map (fun (mp,ms) -> mp,msig_of_ms ms) s - - -(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) - -let get_decl_in_structure r struc = - try - let base_mp,ll = labels_of_ref r in - if not (at_toplevel base_mp) then error_not_visible r; - let sel = List.assoc base_mp struc in - let rec go ll sel = match ll with - | [] -> assert false - | l :: ll -> - match List.assoc l sel with - | SEdecl d -> d - | SEmodtype m -> assert false - | SEmodule m -> - match m.ml_mod_expr with - | MEstruct (_,sel) -> go ll sel - | _ -> error_not_visible r - in go ll sel - with Not_found -> assert false - - -(*s Optimization of a [ml_structure]. *) - -(* Some transformations of ML terms. [optimize_struct] simplify - all beta redexes (when the argument does not occur, it is just - thrown away; when it occurs exactly once it is substituted; otherwise - a let-in redex is created for clarity) and iota redexes, plus some other - optimizations. *) - -let dfix_to_mlfix rv av i = - let rec make_subst n s = - if n < 0 then s - else make_subst (n-1) (Refmap.add rv.(n) (n+1) s) - in - let s = make_subst (Array.length rv - 1) Refmap.empty - in - let rec subst n t = match t with - | MLglob ((ConstRef kn) as refe) -> - (try MLrel (n + (Refmap.find refe s)) with Not_found -> t) - | _ -> ast_map_lift subst n t - in - let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in - let c = Array.map (subst 0) av - in MLfix(i, ids, c) - -let rec optim to_appear s = function - | [] -> [] - | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l -> - if List.mem r to_appear - then d :: (optim to_appear s l) - else optim to_appear s l - | Dterm (r,t,typ) :: l -> - let t = normalize (ast_glob_subst !s t) in - let i = inline r t in - if i then s := Refmap.add r t !s; - if not i || modular () || List.mem r to_appear - then - let d = match optimize_fix t with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|]) - | t -> Dterm (r, t, typ) - in d :: (optim to_appear s l) - else optim to_appear s l - | d :: l -> d :: (optim to_appear s l) - -let rec optim_se top to_appear s = function - | [] -> [] - | (l,SEdecl (Dterm (r,a,t))) :: lse -> - let a = normalize (ast_glob_subst !s a) in - let i = inline r a in - if i then s := Refmap.add r a !s; - if top && i && not (modular ()) && not (List.mem r to_appear) - then optim_se top to_appear s lse - else - let d = match optimize_fix a with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) - | a -> Dterm (r, a, t) - in (l,SEdecl d) :: (optim_se top to_appear s lse) - | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> - let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in - let all = ref true in - (* This fake body ensures that no fixpoint will be auto-inlined. *) - let fake_body = MLfix (0,[||],[||]) in - for i = 0 to Array.length rv - 1 do - if inline rv.(i) fake_body - then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s - else all := false - done; - if !all && top && not (modular ()) - && (array_for_all (fun r -> not (List.mem r to_appear)) rv) - then optim_se top to_appear s lse - else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) - | (l,SEmodule m) :: lse -> - let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} - in (l,SEmodule m) :: (optim_se top to_appear s lse) - | se :: lse -> se :: (optim_se top to_appear s lse) - -and optim_me to_appear s = function - | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse) - | MEident mp as me -> me - | MEapply (me, me') -> - MEapply (optim_me to_appear s me, optim_me to_appear s me') - | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) - -(* After these optimisations, some dependencies may not be needed anymore. - For monolithic extraction, we recompute a minimal set of dependencies. *) - -exception NoDepCheck - -let base_r = function - | ConstRef c as r -> r - | IndRef (kn,_) -> IndRef (kn,0) - | ConstructRef ((kn,_),_) -> IndRef (kn,0) - | _ -> assert false - -let reset_needed, add_needed, found_needed, is_needed = - let needed = ref Refset.empty in - ((fun l -> needed := Refset.empty), - (fun r -> needed := Refset.add (base_r r) !needed), - (fun r -> needed := Refset.remove (base_r r) !needed), - (fun r -> Refset.mem (base_r r) !needed)) - -let declared_refs = function - | Dind (kn,_) -> [|IndRef (kn,0)|] - | Dtype (r,_,_) -> [|r|] - | Dterm (r,_,_) -> [|r|] - | Dfix (rv,_,_) -> rv - -(* Computes the dependencies of a declaration, except in case - of custom extraction. *) - -let compute_deps_decl = function - | Dind (kn,ind) -> - (* Todo Later : avoid dependencies when Extract Inductive *) - ind_iter_references add_needed add_needed add_needed kn ind - | Dtype (r,ids,t) -> - if not (is_custom r) then type_iter_references add_needed t - | Dterm (r,u,t) -> - type_iter_references add_needed t; - if not (is_custom r) then - ast_iter_references add_needed add_needed add_needed u - | Dfix _ as d -> - (* Todo Later : avoid dependencies when Extract Constant *) - decl_iter_references add_needed add_needed add_needed d - -let rec depcheck_se = function - | [] -> [] - | ((l,SEdecl d) as t)::se -> - let se' = depcheck_se se in - let rv = declared_refs d in - if not (array_exists is_needed rv) then - (Array.iter remove_info_axiom rv; se') - else - (Array.iter found_needed rv; compute_deps_decl d; t::se') - | _ -> raise NoDepCheck - -let rec depcheck_struct = function - | [] -> [] - | (mp,lse)::struc -> - let struc' = depcheck_struct struc in - let lse' = depcheck_se lse in - (mp,lse')::struc' - -let optimize_struct to_appear struc = - let subst = ref (Refmap.empty : ml_ast Refmap.t) in - let opt_struc = - List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc - in - let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in - try - if modular () then raise NoDepCheck; - reset_needed (); - List.iter add_needed to_appear; - depcheck_struct opt_struc - with NoDepCheck -> opt_struc diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli deleted file mode 100644 index e279261d..00000000 --- a/contrib/extraction/modutil.mli +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: modutil.mli 11602 2008-11-18 00:08:33Z letouzey $ i*) - -open Names -open Declarations -open Environ -open Libnames -open Miniml -open Mod_subst - -(*s Functions upon ML modules. *) - -val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool -val struct_type_search : (ml_type -> bool) -> ml_structure -> bool - -type do_ref = global_reference -> unit - -val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit -val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit - -val signature_of_structure : ml_structure -> ml_signature - -val msid_of_mt : ml_module_type -> module_path - -val get_decl_in_structure : global_reference -> ml_structure -> ml_decl - -(* Some transformations of ML terms. [optimize_struct] simplify - all beta redexes (when the argument does not occur, it is just - thrown away; when it occurs exactly once it is substituted; otherwise - a let-in redex is created for clarity) and iota redexes, plus some other - optimizations. The first argument is the list of objects we want to appear. -*) - -val optimize_struct : global_reference list -> ml_structure -> ml_structure diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml deleted file mode 100644 index 0166d854..00000000 --- a/contrib/extraction/ocaml.ml +++ /dev/null @@ -1,731 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: ocaml.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) - -(*s Production of Ocaml syntax. *) - -open Pp -open Util -open Names -open Nameops -open Libnames -open Table -open Miniml -open Mlutil -open Modutil -open Common -open Declarations - - -(*s Some utility functions. *) - -let pp_tvar id = - let s = string_of_id id in - if String.length s < 2 || s.[1]<>'\'' - then str ("'"^s) - else str ("' "^s) - -let pp_tuple_light f = function - | [] -> mt () - | [x] -> f true x - | l -> - pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) - -let pp_tuple f = function - | [] -> mt () - | [x] -> f x - | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) - -let pp_boxed_tuple f = function - | [] -> mt () - | [x] -> f x - | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) - -let pp_abst = function - | [] -> mt () - | l -> - str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ - str " ->" ++ spc () - -let pp_parameters l = - (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) - -let pp_string_parameters l = - (pp_boxed_tuple str l ++ space_if (l<>[])) - -(*s Ocaml renaming issues. *) - -let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) - [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; - "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; - "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; - "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; - "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; - "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; - "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; - "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] - Idset.empty - -let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") - -let preamble _ used_modules usf = - prlist pp_open used_modules ++ - (if used_modules = [] then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ - (if usf.mldummy then - str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" - else mt ()) ++ - (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) - -let sig_preamble _ used_modules usf = - prlist pp_open used_modules ++ - (if used_modules = [] then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) - -(*s The pretty-printer for Ocaml syntax*) - -(* Beware of the side-effects of [pp_global] and [pp_modname]. - They are used to update table of content for modules. Many [let] - below should not be altered since they force evaluation order. -*) - -let pp_global k r = - if is_inline_custom r then str (find_custom r) - else str (Common.pp_global k r) - -let pp_modname mp = str (Common.pp_module mp) - - -let is_infix r = - is_inline_custom r && - (let s = find_custom r in - let l = String.length s in - l >= 2 && s.[0] = '(' && s.[l-1] = ')') - -let get_infix r = - let s = find_custom r in - String.sub s 1 (String.length s - 2) - -exception NoRecord - -let find_projections = function Record l -> l | _ -> raise NoRecord - -(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses - are needed or not. *) - -let kn_sig = - let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in - make_kn specif empty_dirpath (mk_label "sig") - -let rec pp_type par vl t = - let rec pp_rec par = function - | Tmeta _ | Tvar' _ | Taxiom -> assert false - | Tvar i -> (try pp_tvar (List.nth vl (pred i)) - with _ -> (str "'a" ++ int i)) - | Tglob (r,[a1;a2]) when is_infix r -> - pp_par par - (pp_rec true a1 ++ spc () ++ str (get_infix r) ++ spc () ++ - pp_rec true a2) - | Tglob (r,[]) -> pp_global Type r - | Tglob (r,l) -> - if r = IndRef (kn_sig,0) then - pp_tuple_light pp_rec l - else - pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r - | Tarr (t1,t2) -> - pp_par par - (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy _ -> str "__" - | Tunknown -> str "__" - in - hov 0 (pp_rec par t) - -(*s Pretty-printing of expressions. [par] indicates whether - parentheses are needed or not. [env] is the list of names for the - de Bruijn variables. [args] is the list of collected arguments - (already pretty-printed). *) - -let is_ifthenelse = function - | [|(r1,[],_);(r2,[],_)|] -> - (try (find_custom r1 = "true") && (find_custom r2 = "false") - with Not_found -> false) - | _ -> false - -let expr_needs_par = function - | MLlam _ -> true - | MLcase (_,_,[|_|]) -> false - | MLcase (_,_,pv) -> not (is_ifthenelse pv) - | _ -> false - - -let rec pp_expr par env args = - let par' = args <> [] || par - and apply st = pp_apply st par args in - function - | MLrel n -> - let id = get_db_name n env in apply (pr_id id) - | MLapp (f,args') -> - let stl = List.map (pp_expr true env []) args' in - pp_expr par env (stl @ args) f - | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl,env' = push_vars fl env in - let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in - apply (pp_par par' st) - | MLletin (id,a1,a2) -> - let i,env' = push_vars [id] env in - let pp_id = pr_id (List.hd i) - and pp_a1 = pp_expr false env [] a1 - and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in - hv 0 - (apply - (pp_par par' - (hv 0 - (hov 2 - (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ - spc () ++ str "in") ++ - spc () ++ hov 0 pp_a2))) - | MLglob r -> - (try - let args = list_skipn (projection_arity r) args in - let record = List.hd args in - pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with _ -> apply (pp_global Term r)) - | MLcons (Coinductive,r,[]) -> - assert (args=[]); - pp_par par (str "lazy " ++ pp_global Cons r) - | MLcons (Coinductive,r,args') -> - assert (args=[]); - let tuple = pp_tuple (pp_expr true env []) args' in - pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")") - | MLcons (_,r,[]) -> - assert (args=[]); - pp_global Cons r - | MLcons (Record projs, r, args') -> - assert (args=[]); - pp_record_pat (projs, List.map (pp_expr true env []) args') - | MLcons (_,r,[arg1;arg2]) when is_infix r -> - assert (args=[]); - pp_par par - ((pp_expr true env [] arg1) ++ spc () ++ str (get_infix r) ++ - spc () ++ (pp_expr true env [] arg2)) - | MLcons (_,r,args') -> - assert (args=[]); - let tuple = pp_tuple (pp_expr true env []) args' in - pp_par par (pp_global Cons r ++ spc () ++ tuple) - | MLcase ((i,factors), t, pv) -> - let expr = if i = Coinductive then - (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) - else - (pp_expr false env [] t) - in - (try - let projs = find_projections i in - let (_, ids, c) = pv.(0) in - let n = List.length ids in - match c with - | MLrel i when i <= n -> - apply (pp_par par' (pp_expr true env [] t ++ str "." ++ - pp_global Term (List.nth projs (n-i)))) - | MLapp (MLrel i, a) when i <= n -> - if List.exists (ast_occurs_itvl 1 n) a - then raise NoRecord - else - let ids,env' = push_vars (List.rev ids) env in - (pp_apply - (pp_expr true env [] t ++ str "." ++ - pp_global Term (List.nth projs (n-i))) - par ((List.map (pp_expr true env' []) a) @ args)) - | _ -> raise NoRecord - with NoRecord -> - if Array.length pv = 1 then - let s1,s2 = pp_one_pat env i pv.(0) in - apply - (hv 0 - (pp_par par' - (hv 0 - (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) - ++ spc () ++ str "in") ++ - spc () ++ hov 0 s2))) - else - apply - (pp_par par' - (try pp_ifthenelse par' env expr pv - with Not_found -> - v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++ - str " | " ++ pp_pat env (i,factors) pv)))) - | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix par env' i (Array.of_list (List.rev ids'),defs) args - | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) - | MLmagic a -> - pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) - | MLaxiom -> - pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") - - -and pp_record_pat (projs, args) = - str "{ " ++ - prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a) - (List.combine projs args) ++ - str " }" - -and pp_ifthenelse par env expr pv = match pv with - | [|(tru,[],the);(fal,[],els)|] when - (find_custom tru = "true") && (find_custom fal = "false") - -> - hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ - hov 2 (str "then " ++ - hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ - hov 2 (str "else " ++ - hov 2 (pp_expr (expr_needs_par els) env [] els))) - | _ -> raise Not_found - -and pp_one_pat env i (r,ids,t) = - let ids,env' = push_vars (List.rev ids) env in - let expr = pp_expr (expr_needs_par t) env' [] t in - try - let projs = find_projections i in - pp_record_pat (projs, List.rev_map pr_id ids), expr - with NoRecord -> - (match List.rev ids with - | [i1;i2] when is_infix r -> - pr_id i1 ++ str " " ++ str (get_infix r) ++ str " " ++ pr_id i2 - | [] -> pp_global Cons r - | ids -> pp_global Cons r ++ str " " ++ pp_boxed_tuple pr_id ids), - expr - -and pp_pat env (info,factors) pv = - prvecti - (fun i x -> if List.mem i factors then mt () else - let s1,s2 = pp_one_pat env info x in - hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++ - (if factors = [] && i = Array.length pv-1 then mt () - else fnl () ++ str " | ")) pv - ++ - match factors with - | [] -> mt () - | i::_ -> - let (_,ids,t) = pv.(i) in - let t = ast_lift (-List.length ids) t in - hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t) - -and pp_function env t = - let bl,t' = collect_lams t in - let bl,env' = push_vars bl env in - match t' with - | MLcase(i,MLrel 1,pv) when fst i=Standard -> - if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then - pr_binding (List.rev (List.tl bl)) ++ - str " = function" ++ fnl () ++ - v 0 (str " | " ++ pp_pat env' i pv) - else - pr_binding (List.rev bl) ++ - str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ - v 0 (str " | " ++ pp_pat env' i pv) - | _ -> - pr_binding (List.rev bl) ++ - str " =" ++ fnl () ++ str " " ++ - hov 2 (pp_expr false env' [] t') - -(*s names of the functions ([ids]) are already pushed in [env], - and passed here just for convenience. *) - -and pp_fix par env i (ids,bl) args = - pp_par par - (v 0 (str "let rec " ++ - prvect_with_sep - (fun () -> fnl () ++ str "and ") - (fun (fi,ti) -> pr_id fi ++ pp_function env ti) - (array_map2 (fun id b -> (id,b)) ids bl) ++ - fnl () ++ - hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) - -let pp_val e typ = - hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ - str " **)") ++ fnl2 () - -(*s Pretty-printing of [Dfix] *) - -let pp_Dfix (rv,c,t) = - let names = Array.map - (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv - in - let rec pp sep letand i = - if i >= Array.length rv then mt () - else if is_inline_custom rv.(i) then pp sep letand (i+1) - else - let def = - if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) - else pp_function (empty_env ()) c.(i) - in - sep () ++ pp_val names.(i) t.(i) ++ - str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1) - in pp mt "let rec " 0 - -(*s Pretty-printing of inductive types declaration. *) - -let pp_equiv param_list name = function - | NoEquiv, _ -> mt () - | Equiv kn, i -> - str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (kn,i)) - | RenEquiv ren, _ -> - str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name - -let pp_comment s = str "(* " ++ s ++ str " *)" - -let pp_one_ind prefix ip_equiv pl name cnames ctyps = - let pl = rename_tvars keywords pl in - let pp_constructor i typs = - (if i=0 then mt () else fnl ()) ++ - hov 5 (str " | " ++ cnames.(i) ++ - (if typs = [] then mt () else str " of ") ++ - prlist_with_sep - (fun () -> spc () ++ str "* ") (pp_type true pl) typs) - in - pp_parameters pl ++ str prefix ++ name ++ - pp_equiv pl name ip_equiv ++ str " =" ++ - if Array.length ctyps = 0 then str " unit (* empty inductive *)" - else fnl () ++ v 0 (prvecti pp_constructor ctyps) - -let pp_logical_ind packet = - pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ - fnl () ++ - pp_comment (str "with constructors : " ++ - prvect_with_sep spc pr_id packet.ip_consnames) ++ - fnl () - -let pp_singleton kn packet = - let name = pp_global Type (IndRef (kn,0)) in - let l = rename_tvars keywords packet.ip_vars in - hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ - pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ - pp_comment (str "singleton inductive, whose constructor was " ++ - pr_id packet.ip_consnames.(0))) - -let pp_record kn projs ip_equiv packet = - let name = pp_global Type (IndRef (kn,0)) in - let projnames = List.map (pp_global Term) projs in - let l = List.combine projnames packet.ip_types.(0) in - let pl = rename_tvars keywords packet.ip_vars in - str "type " ++ pp_parameters pl ++ name ++ - pp_equiv pl name ip_equiv ++ str " = { "++ - hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) - ++ str " }" - -let pp_coind pl name = - let pl = rename_tvars keywords pl in - pp_parameters pl ++ name ++ str " = " ++ - pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++ - fnl() ++ str "and " - -let pp_ind co kn ind = - let prefix = if co then "__" else "" in - let some = ref false in - let init= ref (str "type ") in - let names = - Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (IndRef (kn,i))) - ind.ind_packets - in - let cnames = - Array.mapi - (fun i p -> if p.ip_logical then [||] else - Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) - p.ip_types) - ind.ind_packets - in - let rec pp i = - if i >= Array.length ind.ind_packets then mt () - else - let ip = (kn,i) in - let ip_equiv = ind.ind_equiv, i in - let p = ind.ind_packets.(i) in - if is_custom (IndRef ip) then pp (i+1) - else begin - some := true; - if p.ip_logical then pp_logical_ind p ++ pp (i+1) - else - let s = !init in - begin - init := (fnl () ++ str "and "); - s ++ - (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ - pp_one_ind - prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ - pp (i+1) - end - end - in - let st = pp 0 in if !some then st else failwith "empty phrase" - - -(*s Pretty-printing of a declaration. *) - -let pp_mind kn i = - match i.ind_info with - | Singleton -> pp_singleton kn i.ind_packets.(0) - | Coinductive -> pp_ind true kn i - | Record projs -> - pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0) - | Standard -> pp_ind false kn i - -let pp_decl = function - | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Dind (kn,i) -> pp_mind kn i - | Dtype (r, l, t) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids, def = - try - let ids,s = find_type_custom r in - pp_string_parameters ids, str "=" ++ spc () ++ str s - with Not_found -> - pp_parameters l, - if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" - else str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) - | Dterm (r, a, t) -> - let def = - if is_custom r then str (" = " ^ find_custom r) - else if is_projection r then - (prvect str (Array.make (projection_arity r) " _")) ++ - str " x = x." - else pp_function (empty_env ()) a - in - let name = pp_global Term r in - let postdef = if is_projection r then name else mt () in - pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) - | Dfix (rv,defs,typs) -> - pp_Dfix (rv,defs,typs) - -let pp_alias_decl ren = function - | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Dtype (r, l, _) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Dterm (r, a, t) -> - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) - | Dfix (rv, _, _) -> - prvecti (fun i r -> if is_inline_custom r then mt () else - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ - fnl ()) - rv - -let pp_spec = function - | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" - | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Sind (kn,i) -> pp_mind kn i - | Sval (r,t) -> - let def = pp_type false [] t in - let name = pp_global Term r in - hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) - | Stype (r,vl,ot) -> - let name = pp_global Type r in - let l = rename_tvars keywords vl in - let ids, def = - try - let ids, s = find_type_custom r in - pp_string_parameters ids, str "= " ++ str s - with Not_found -> - let ids = pp_parameters l in - match ot with - | None -> ids, mt () - | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" - | Some t -> ids, str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) - -let pp_alias_spec ren = function - | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Stype (r,l,_) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Sval _ -> assert false - -let rec pp_specif = function - | (_,Spec (Sval _ as s)) -> pp_spec s - | (l,Spec s) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ - fnl () ++ str "end" ++ fnl () ++ - pp_alias_spec ren s - with Not_found -> pp_spec s) - | (l,Smodule mt) -> - let def = pp_module_type (Some l) mt in - let def' = pp_module_type (Some l) mt in - let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') - with Not_found -> Pp.mt ()) - | (l,Smodtype mt) -> - let def = pp_module_type None mt in - let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> Pp.mt ()) - -and pp_module_type ol = function - | MTident kn -> - pp_modname kn - | MTfunsig (mbid, mt, mt') -> - let typ = pp_module_type None mt in - let name = pp_modname (MPbound mbid) in - let def = pp_module_type None mt' in - str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def - | MTsig (msid, sign) -> - let tvm = top_visible_mp () in - let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in - (* References in [sign] are in short form (relative to [msid]). - In push_visible, [msid-->mp] is added to the current subst. *) - push_visible mp (Some msid); - let l = map_succeed pp_specif sign in - pop_visible (); - str "sig " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ - fnl () ++ str "end" - | MTwith(mt,ML_With_type(idl,vl,typ)) -> - let ids = pp_parameters (rename_tvars keywords vl) in - let mp_mt = msid_of_mt mt in - let l,idl' = list_sep_last idl in - let mp_w = - List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl' - in - let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) - in - push_visible mp_mt None; - let s = - pp_module_type None mt ++ str " with type " ++ - pp_global Type r ++ ids - in - pop_visible(); - s ++ str "=" ++ spc () ++ pp_type false vl typ - | MTwith(mt,ML_With_module(idl,mp)) -> - let mp_mt = msid_of_mt mt in - let mp_w = - List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl - in - push_visible mp_mt None; - let s = - pp_module_type None mt ++ str " with module " ++ pp_modname mp_w - in - pop_visible (); - s ++ str " = " ++ pp_modname mp - -let is_short = function MEident _ | MEapply _ -> true | _ -> false - -let rec pp_structure_elem = function - | (l,SEdecl d) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ - fnl () ++ str "end" ++ fnl () ++ - pp_alias_decl ren d - with Not_found -> pp_decl d) - | (l,SEmodule m) -> - let typ = - (* virtual printing of the type, in order to have a correct mli later*) - if Common.get_phase () = Pre then - str ": " ++ pp_module_type (Some l) m.ml_mod_type - else mt () - in - let def = pp_module_expr (Some l) m.ml_mod_expr in - let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 - (str "module " ++ name ++ typ ++ str " = " ++ - (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module "^ren^" = ") ++ name - with Not_found -> mt ()) - | (l,SEmodtype m) -> - let def = pp_module_type None m in - let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> mt ()) - -and pp_module_expr ol = function - | MEident mp' -> pp_modname mp' - | MEfunctor (mbid, mt, me) -> - let name = pp_modname (MPbound mbid) in - let typ = pp_module_type None mt in - let def = pp_module_expr None me in - str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def - | MEapply (me, me') -> - pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")" - | MEstruct (msid, sel) -> - let tvm = top_visible_mp () in - let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in - (* No need to update the subst with [Some msid] below : names are - already in long form (see [subst_structure] in [Extract_env]). *) - push_visible mp None; - let l = map_succeed pp_structure_elem sel in - pop_visible (); - str "struct " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ - fnl () ++ str "end" - -let do_struct f s = - let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () - in - let ppl (mp,sel) = - push_visible mp None; - let p = prlist_strict pp sel in - (* for monolithic extraction, we try to simulate the unavailability - of [MPfile] in names by artificially nesting these [MPfile] *) - (if modular () then pop_visible ()); p - in - let p = prlist_strict ppl s in - (if not (modular ()) then repeat (List.length s) pop_visible ()); - p - -let pp_struct s = do_struct pp_structure_elem s - -let pp_signature s = do_struct pp_specif s - -let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () - -let ocaml_descr = { - keywords = keywords; - file_suffix = ".ml"; - capital_file = false; - preamble = preamble; - pp_struct = pp_struct; - sig_suffix = Some ".mli"; - sig_preamble = sig_preamble; - pp_sig = pp_signature; - pp_decl = pp_decl; -} - - diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli deleted file mode 100644 index 3d90e74c..00000000 --- a/contrib/extraction/ocaml.mli +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: ocaml.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) - -val ocaml_descr : Miniml.language_descr - diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml deleted file mode 100644 index f4941a9c..00000000 --- a/contrib/extraction/scheme.ml +++ /dev/null @@ -1,202 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: scheme.ml 11559 2008-11-07 22:03:34Z letouzey $ i*) - -(*s Production of Scheme syntax. *) - -open Pp -open Util -open Names -open Nameops -open Libnames -open Miniml -open Mlutil -open Table -open Common - -(*s Scheme renaming issues. *) - -let keywords = - List.fold_right (fun s -> Idset.add (id_of_string s)) - [ "define"; "let"; "lambda"; "lambdas"; "match"; - "apply"; "car"; "cdr"; - "error"; "delay"; "force"; "_"; "__"] - Idset.empty - -let preamble _ _ usf = - str ";; This extracted scheme code relies on some additional macros\n" ++ - str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++ - str "(load \"macros_extr.scm\")\n\n" ++ - (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) - -let pr_id id = - let s = string_of_id id in - for i = 0 to String.length s - 1 do - if s.[i] = '\'' then s.[i] <- '~' - done; - str s - -let paren = pp_par true - -let pp_abst st = function - | [] -> assert false - | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) - | l -> paren - (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) - -let pp_apply st _ = function - | [] -> st - | [a] -> hov 2 (paren (st ++ spc () ++ a)) - | args -> hov 2 (paren (str "@ " ++ st ++ - (prlist_strict (fun x -> spc () ++ x) args))) - -(*s The pretty-printer for Scheme syntax *) - -let pp_global k r = str (Common.pp_global k r) - -(*s Pretty-printing of expressions. *) - -let rec pp_expr env args = - let apply st = pp_apply st true args in - function - | MLrel n -> - let id = get_db_name n env in apply (pr_id id) - | MLapp (f,args') -> - let stl = List.map (pp_expr env []) args' in - pp_expr env (stl @ args) f - | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl,env' = push_vars fl env in - apply (pp_abst (pp_expr env' [] a') (List.rev fl)) - | MLletin (id,a1,a2) -> - let i,env' = push_vars [id] env in - apply - (hv 0 - (hov 2 - (paren - (str "let " ++ - paren - (paren - (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) - ++ spc () ++ hov 0 (pp_expr env' [] a2))))) - | MLglob r -> - apply (pp_global Term r) - | MLcons (i,r,args') -> - assert (args=[]); - let st = - str "`" ++ - paren (pp_global Cons r ++ - (if args' = [] then mt () else spc ()) ++ - prlist_with_sep spc (pp_cons_args env) args') - in - if i = Coinductive then paren (str "delay " ++ st) else st - | MLcase ((i,_),t, pv) -> - let e = - if i <> Coinductive then pp_expr env [] t - else paren (str "force" ++ spc () ++ pp_expr env [] t) - in - apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) - | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix env' i (Array.of_list (List.rev ids'),defs) args - | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - paren (str "error" ++ spc () ++ qs s) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) - | MLmagic a -> - pp_expr env args a - | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") - -and pp_cons_args env = function - | MLcons (i,r,args) when i<>Coinductive -> - paren (pp_global Cons r ++ - (if args = [] then mt () else spc ()) ++ - prlist_with_sep spc (pp_cons_args env) args) - | e -> str "," ++ pp_expr env [] e - - -and pp_one_pat env (r,ids,t) = - let ids,env' = push_vars (List.rev ids) env in - let args = - if ids = [] then mt () - else (str " " ++ prlist_with_sep spc pr_id (List.rev ids)) - in - (pp_global Cons r ++ args), (pp_expr env' [] t) - -and pp_pat env pv = - prvect_with_sep fnl - (fun x -> let s1,s2 = pp_one_pat env x in - hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv - -(*s names of the functions ([ids]) are already pushed in [env], - and passed here just for convenience. *) - -and pp_fix env j (ids,bl) args = - paren - (str "letrec " ++ - (v 0 (paren - (prvect_with_sep fnl - (fun (fi,ti) -> - paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) - (array_map2 (fun id b -> (id,b)) ids bl)) ++ - fnl () ++ - hov 2 (pp_apply (pr_id (ids.(j))) true args)))) - -(*s Pretty-printing of a declaration. *) - -let pp_decl = function - | Dind _ -> mt () - | Dtype _ -> mt () - | Dfix (rv, defs,_) -> - let ppv = Array.map (pp_global Term) rv in - prvect_with_sep fnl - (fun (pi,ti) -> - hov 2 - (paren (str "define " ++ pi ++ spc () ++ - (pp_expr (empty_env ()) [] ti)) - ++ fnl ())) - (array_map2 (fun p b -> (p,b)) ppv defs) ++ - fnl () - | Dterm (r, a, _) -> - if is_inline_custom r then mt () - else - if is_custom r then - hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ - str (find_custom r))) ++ fnl () ++ fnl () - else - hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ - pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl () - -let pp_structure_elem = function - | (l,SEdecl d) -> pp_decl d - | (l,SEmodule m) -> - failwith "TODO: Scheme extraction of modules not implemented yet" - | (l,SEmodtype m) -> - failwith "TODO: Scheme extraction of modules not implemented yet" - -let pp_struct = - let pp_sel (mp,sel) = - push_visible mp None; - let p = prlist_strict pp_structure_elem sel in - pop_visible (); p - in - prlist_strict pp_sel - -let scheme_descr = { - keywords = keywords; - file_suffix = ".scm"; - capital_file = false; - preamble = preamble; - pp_struct = pp_struct; - sig_suffix = None; - sig_preamble = (fun _ _ _ -> mt ()); - pp_sig = (fun _ -> mt ()); - pp_decl = pp_decl; -} diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli deleted file mode 100644 index a88bb6db..00000000 --- a/contrib/extraction/scheme.mli +++ /dev/null @@ -1,11 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: scheme.mli 10232 2007-10-17 12:32:10Z letouzey $ i*) - -val scheme_descr : Miniml.language_descr diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml deleted file mode 100644 index c675a744..00000000 --- a/contrib/extraction/table.ml +++ /dev/null @@ -1,653 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: table.ml 11844 2009-01-22 16:45:06Z letouzey $ i*) - -open Names -open Term -open Declarations -open Nameops -open Summary -open Libobject -open Goptions -open Libnames -open Util -open Pp -open Miniml - -(*S Utilities about [module_path] and [kernel_names] and [global_reference] *) - -let occur_kn_in_ref kn = function - | IndRef (kn',_) - | ConstructRef ((kn',_),_) -> kn = kn' - | ConstRef _ -> false - | VarRef _ -> assert false - -let modpath_of_r = function - | ConstRef kn -> con_modpath kn - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> modpath kn - | VarRef _ -> assert false - -let label_of_r = function - | ConstRef kn -> con_label kn - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> label kn - | VarRef _ -> assert false - -let rec base_mp = function - | MPdot (mp,l) -> base_mp mp - | mp -> mp - -let rec mp_length = function - | MPdot (mp, _) -> 1 + (mp_length mp) - | _ -> 1 - -let is_modfile = function - | MPfile _ -> true - | _ -> false - -let raw_string_of_modfile = function - | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) - | _ -> assert false - -let rec modfile_of_mp = function - | (MPfile _) as mp -> mp - | MPdot (mp,_) -> modfile_of_mp mp - | _ -> raise Not_found - -let current_toplevel () = fst (Lib.current_prefix ()) - -let is_toplevel mp = - mp = initial_path || mp = current_toplevel () - -let at_toplevel mp = - is_modfile mp || is_toplevel mp - -let visible_kn kn = at_toplevel (base_mp (modpath kn)) -let visible_con kn = at_toplevel (base_mp (con_modpath kn)) - -let rec prefixes_mp mp = match mp with - | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') - | _ -> MPset.singleton mp - -let rec get_nth_label_mp n = function - | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp - | _ -> failwith "get_nth_label: not enough MPdot" - -let common_prefix_from_list mp0 mpl = - let prefixes = prefixes_mp mp0 in - let rec f = function - | [] -> raise Not_found - | mp :: l -> if MPset.mem mp prefixes then mp else f l - in f mpl - -let rec parse_labels ll = function - | MPdot (mp,l) -> parse_labels (l::ll) mp - | mp -> mp,ll - -let labels_of_mp mp = parse_labels [] mp - -let labels_of_ref r = - let mp,_,l = - match r with - ConstRef con -> repr_con con - | IndRef (kn,_) - | ConstructRef ((kn,_),_) -> repr_kn kn - | VarRef _ -> assert false - in - parse_labels [l] mp - -let rec add_labels_mp mp = function - | [] -> mp - | l :: ll -> add_labels_mp (MPdot (mp,l)) ll - - -(*S The main tables: constants, inductives, records, ... *) - -(* Theses tables are not registered within coq save/undo mechanism - since we reset their contents at each run of Extraction *) - -(*s Constants tables. *) - -let terms = ref (Cmap.empty : ml_decl Cmap.t) -let init_terms () = terms := Cmap.empty -let add_term kn d = terms := Cmap.add kn d !terms -let lookup_term kn = Cmap.find kn !terms - -let types = ref (Cmap.empty : ml_schema Cmap.t) -let init_types () = types := Cmap.empty -let add_type kn s = types := Cmap.add kn s !types -let lookup_type kn = Cmap.find kn !types - -(*s Inductives table. *) - -let inductives = ref (KNmap.empty : (mutual_inductive_body * ml_ind) KNmap.t) -let init_inductives () = inductives := KNmap.empty -let add_ind kn mib ml_ind = inductives := KNmap.add kn (mib,ml_ind) !inductives -let lookup_ind kn = KNmap.find kn !inductives - -(*s Recursors table. *) - -let recursors = ref Cset.empty -let init_recursors () = recursors := Cset.empty - -let add_recursors env kn = - let make_kn id = make_con (modpath kn) empty_dirpath (label_of_id id) in - let mib = Environ.lookup_mind kn env in - Array.iter - (fun mip -> - let id = mip.mind_typename in - let kn_rec = make_kn (Nameops.add_suffix id "_rec") - and kn_rect = make_kn (Nameops.add_suffix id "_rect") in - recursors := Cset.add kn_rec (Cset.add kn_rect !recursors)) - mib.mind_packets - -let is_recursor = function - | ConstRef kn -> Cset.mem kn !recursors - | _ -> false - -(*s Record tables. *) - -let projs = ref (Refmap.empty : int Refmap.t) -let init_projs () = projs := Refmap.empty -let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs -let is_projection r = Refmap.mem r !projs -let projection_arity r = Refmap.find r !projs - -(*s Table of used axioms *) - -let info_axioms = ref Refset.empty -let log_axioms = ref Refset.empty -let init_axioms () = info_axioms := Refset.empty; log_axioms := Refset.empty -let add_info_axiom r = info_axioms := Refset.add r !info_axioms -let remove_info_axiom r = info_axioms := Refset.remove r !info_axioms -let add_log_axiom r = log_axioms := Refset.add r !log_axioms - -(*s Extraction mode: modular or monolithic *) - -let modular_ref = ref false - -let set_modular b = modular_ref := b -let modular () = !modular_ref - -(*s Printing. *) - -(* The following functions work even on objects not in [Global.env ()]. - WARNING: for inductive objects, an extract_inductive must have been - done before. *) - -let safe_id_of_global = function - | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l - | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename - | ConstructRef ((kn,i),j) -> - (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) - | _ -> assert false - -let safe_pr_global r = - try Printer.pr_global r - with _ -> pr_id (safe_id_of_global r) - -(* idem, but with qualification, and only for constants. *) - -let safe_pr_long_global r = - try Printer.pr_global r - with _ -> match r with - | ConstRef kn -> - let mp,_,l = repr_con kn in - str ((string_of_mp mp)^"."^(string_of_label l)) - | _ -> assert false - -let pr_long_mp mp = - let lid = repr_dirpath (Nametab.dir_of_mp mp) in - str (String.concat "." (List.map string_of_id (List.rev lid))) - -let pr_long_global ref = pr_sp (Nametab.sp_of_global ref) - -(*S Warning and Error messages. *) - -let err s = errorlabstrm "Extraction" s - -let warning_axioms () = - let info_axioms = Refset.elements !info_axioms in - if info_axioms = [] then () - else begin - let s = if List.length info_axioms = 1 then "axiom" else "axioms" in - msg_warning - (str ("The following "^s^" must be realized in the extracted code:") - ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) - ++ str "." ++ fnl ()) - end; - let log_axioms = Refset.elements !log_axioms in - if log_axioms = [] then () - else begin - let s = if List.length log_axioms = 1 then "axiom was" else "axioms were" - in - msg_warning - (str ("The following logical "^s^" encountered:") ++ - hov 1 - (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") - ++ - str "Having invalid logical axiom in the environment when extracting" ++ - spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ - fnl ()) - end - -let warning_both_mod_and_cst q mp r = - msg_warning - (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ - str "do you mean module " ++ - pr_long_mp mp ++ - str " or object " ++ - pr_long_global r ++ str " ?" ++ fnl () ++ - str "First choice is assumed, for the second one please use " ++ - str "fully qualified name." ++ fnl ()) - -let error_axiom_scheme r i = - err (str "The type scheme axiom " ++ spc () ++ - safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ - str " type variable(s).") - -let check_inside_module () = - if Lib.is_modtype () then - err (str "You can't do that within a Module Type." ++ fnl () ++ - str "Close it and try again.") - else if Lib.is_module () then - msg_warning - (str "Extraction inside an opened module is experimental.\n" ++ - str "In case of problem, close it first.\n") - -let check_inside_section () = - if Lib.sections_are_opened () then - err (str "You can't do that within a section." ++ fnl () ++ - str "Close it and try again.") - -let error_constant r = - err (safe_pr_global r ++ str " is not a constant.") - -let error_inductive r = - err (safe_pr_global r ++ spc () ++ str "is not an inductive type.") - -let error_nb_cons () = - err (str "Not the right number of constructors.") - -let error_module_clash s = - err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ - str "This is not supported yet. Please do some renaming first.") - -let error_unknown_module m = - err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") - -let error_scheme () = - err (str "No Scheme modular extraction available yet.") - -let error_not_visible r = - err (safe_pr_global r ++ str " is not directly visible.\n" ++ - str "For example, it may be inside an applied functor." ++ - str "Use Recursive Extraction to get the whole environment.") - -let error_MPfile_as_mod mp b = - let s1 = if b then "asked" else "required" in - let s2 = if b then "extract some objects of this module or\n" else "" in - err (str ("Extraction of file "^(raw_string_of_modfile mp)^ - ".v as a module is "^s1^".\n"^ - "Monolithic Extraction cannot deal with this situation.\n"^ - "Please "^s2^"use (Recursive) Extraction Library instead.\n")) - -let error_record r = - err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++ - fnl () ++ str "To help extraction, please use an explicit name.") - -let check_loaded_modfile mp = match base_mp mp with - | MPfile dp -> if not (Library.library_is_loaded dp) then - err (str ("Please load library "^(string_of_dirpath dp^" first."))) - | _ -> () - -let info_file f = - Flags.if_verbose message - ("The file "^f^" has been created by extraction.") - - -(*S The Extraction auxiliary commands *) - -(* The objects defined below should survive an arbitrary time, - so we register them to coq save/undo mechanism. *) - -(*s Extraction AutoInline *) - -let auto_inline_ref = ref true - -let auto_inline () = !auto_inline_ref - -let _ = declare_bool_option - {optsync = true; - optname = "Extraction AutoInline"; - optkey = SecondaryTable ("Extraction", "AutoInline"); - optread = auto_inline; - optwrite = (:=) auto_inline_ref} - -(*s Extraction TypeExpand *) - -let type_expand_ref = ref true - -let type_expand () = !type_expand_ref - -let _ = declare_bool_option - {optsync = true; - optname = "Extraction TypeExpand"; - optkey = SecondaryTable ("Extraction", "TypeExpand"); - optread = type_expand; - optwrite = (:=) type_expand_ref} - -(*s Extraction Optimize *) - -type opt_flag = - { opt_kill_dum : bool; (* 1 *) - opt_fix_fun : bool; (* 2 *) - opt_case_iot : bool; (* 4 *) - opt_case_idr : bool; (* 8 *) - opt_case_idg : bool; (* 16 *) - opt_case_cst : bool; (* 32 *) - opt_case_fun : bool; (* 64 *) - opt_case_app : bool; (* 128 *) - opt_let_app : bool; (* 256 *) - opt_lin_let : bool; (* 512 *) - opt_lin_beta : bool } (* 1024 *) - -let kth_digit n k = (n land (1 lsl k) <> 0) - -let flag_of_int n = - { opt_kill_dum = kth_digit n 0; - opt_fix_fun = kth_digit n 1; - opt_case_iot = kth_digit n 2; - opt_case_idr = kth_digit n 3; - opt_case_idg = kth_digit n 4; - opt_case_cst = kth_digit n 5; - opt_case_fun = kth_digit n 6; - opt_case_app = kth_digit n 7; - opt_let_app = kth_digit n 8; - opt_lin_let = kth_digit n 9; - opt_lin_beta = kth_digit n 10 } - -(* For the moment, we allow by default everything except the type-unsafe - optimization [opt_case_idg]. *) - -let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024 - -let int_flag_ref = ref int_flag_init -let opt_flag_ref = ref (flag_of_int int_flag_init) - -let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n - -let optims () = !opt_flag_ref - -let _ = declare_bool_option - {optsync = true; - optname = "Extraction Optimize"; - optkey = SecondaryTable ("Extraction", "Optimize"); - optread = (fun () -> !int_flag_ref <> 0); - optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} - -let _ = declare_int_option - { optsync = true; - optname = "Extraction Flag"; - optkey = SecondaryTable("Extraction","Flag"); - optread = (fun _ -> Some !int_flag_ref); - optwrite = (function - | None -> chg_flag 0 - | Some i -> chg_flag (max i 0))} - - -(*s Extraction Lang *) - -type lang = Ocaml | Haskell | Scheme - -let lang_ref = ref Ocaml - -let lang () = !lang_ref - -let (extr_lang,_) = - declare_object - {(default_object "Extraction Lang") with - cache_function = (fun (_,l) -> lang_ref := l); - load_function = (fun _ (_,l) -> lang_ref := l); - export_function = (fun x -> Some x)} - -let _ = declare_summary "Extraction Lang" - { freeze_function = (fun () -> !lang_ref); - unfreeze_function = ((:=) lang_ref); - init_function = (fun () -> lang_ref := Ocaml); - survive_module = true; - survive_section = true } - -let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) - -(*s Extraction Inline/NoInline *) - -let empty_inline_table = (Refset.empty,Refset.empty) - -let inline_table = ref empty_inline_table - -let to_inline r = Refset.mem r (fst !inline_table) - -let to_keep r = Refset.mem r (snd !inline_table) - -let add_inline_entries b l = - let f b = if b then Refset.add else Refset.remove in - let i,k = !inline_table in - inline_table := - (List.fold_right (f b) l i), - (List.fold_right (f (not b)) l k) - -(* Registration of operations for rollback. *) - -let (inline_extraction,_) = - declare_object - {(default_object "Extraction Inline") with - cache_function = (fun (_,(b,l)) -> add_inline_entries b l); - load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); - export_function = (fun x -> Some x); - classify_function = (fun (_,o) -> Substitute o); - subst_function = - (fun (_,s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) - } - -let _ = declare_summary "Extraction Inline" - { freeze_function = (fun () -> !inline_table); - unfreeze_function = ((:=) inline_table); - init_function = (fun () -> inline_table := empty_inline_table); - survive_module = true; - survive_section = true } - -(* Grammar entries. *) - -let extraction_inline b l = - check_inside_section (); - let refs = List.map Nametab.global l in - List.iter - (fun r -> match r with - | ConstRef _ -> () - | _ -> error_constant r) refs; - Lib.add_anonymous_leaf (inline_extraction (b,refs)) - -(* Printing part *) - -let print_extraction_inline () = - let (i,n)= !inline_table in - let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in - msg - (str "Extraction Inline:" ++ fnl () ++ - Refset.fold - (fun r p -> - (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ - str "Extraction NoInline:" ++ fnl () ++ - Refset.fold - (fun r p -> - (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) - -(* Reset part *) - -let (reset_inline,_) = - declare_object - {(default_object "Reset Extraction Inline") with - cache_function = (fun (_,_)-> inline_table := empty_inline_table); - load_function = (fun _ (_,_)-> inline_table := empty_inline_table); - export_function = (fun x -> Some x)} - -let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) - -(*s Extraction Blacklist of filenames not to use while extracting *) - -let blacklist_table = ref Idset.empty - -let modfile_ids = ref [] -let modfile_mps = ref MPmap.empty - -let reset_modfile () = - modfile_ids := Idset.elements !blacklist_table; - modfile_mps := MPmap.empty - -let string_of_modfile mp = - try MPmap.find mp !modfile_mps - with Not_found -> - let id = id_of_string (raw_string_of_modfile mp) in - let id' = next_ident_away id !modfile_ids in - let s' = string_of_id id' in - modfile_ids := id' :: !modfile_ids; - modfile_mps := MPmap.add mp s' !modfile_mps; - s' - -let add_blacklist_entries l = - blacklist_table := - List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s))) - l !blacklist_table - -(* Registration of operations for rollback. *) - -let (blacklist_extraction,_) = - declare_object - {(default_object "Extraction Blacklist") with - cache_function = (fun (_,l) -> add_blacklist_entries l); - load_function = (fun _ (_,l) -> add_blacklist_entries l); - export_function = (fun x -> Some x); - classify_function = (fun (_,o) -> Libobject.Keep o); - subst_function = (fun (_,_,x) -> x) - } - -let _ = declare_summary "Extraction Blacklist" - { freeze_function = (fun () -> !blacklist_table); - unfreeze_function = ((:=) blacklist_table); - init_function = (fun () -> blacklist_table := Idset.empty); - survive_module = true; - survive_section = true } - -(* Grammar entries. *) - -let extraction_blacklist l = - let l = List.rev_map string_of_id l in - Lib.add_anonymous_leaf (blacklist_extraction l) - -(* Printing part *) - -let print_extraction_blacklist () = - msgnl - (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table)) - -(* Reset part *) - -let (reset_blacklist,_) = - declare_object - {(default_object "Reset Extraction Blacklist") with - cache_function = (fun (_,_)-> blacklist_table := Idset.empty); - load_function = (fun _ (_,_)-> blacklist_table := Idset.empty); - export_function = (fun x -> Some x)} - -let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ()) - -(*s Extract Constant/Inductive. *) - -(* UGLY HACK: to be defined in [extraction.ml] *) -let use_type_scheme_nb_args, register_type_scheme_nb_args = - let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r - -let customs = ref Refmap.empty - -let add_custom r ids s = customs := Refmap.add r (ids,s) !customs - -let is_custom r = Refmap.mem r !customs - -let is_inline_custom r = (is_custom r) && (to_inline r) - -let find_custom r = snd (Refmap.find r !customs) - -let find_type_custom r = Refmap.find r !customs - -(* Registration of operations for rollback. *) - -let (in_customs,_) = - declare_object - {(default_object "ML extractions") with - cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); - load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); - export_function = (fun x -> Some x); - classify_function = (fun (_,o) -> Substitute o); - subst_function = - (fun (_,s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) - } - -let _ = declare_summary "ML extractions" - { freeze_function = (fun () -> !customs); - unfreeze_function = ((:=) customs); - init_function = (fun () -> customs := Refmap.empty); - survive_module = true; - survive_section = true } - -(* Grammar entries. *) - -let extract_constant_inline inline r ids s = - check_inside_section (); - let g = Nametab.global r in - match g with - | ConstRef kn -> - let env = Global.env () in - let typ = Typeops.type_of_constant env kn in - let typ = Reduction.whd_betadeltaiota env typ in - if Reduction.is_arity env typ - then begin - let nargs = use_type_scheme_nb_args env typ in - if List.length ids <> nargs then error_axiom_scheme g nargs - end; - Lib.add_anonymous_leaf (inline_extraction (inline,[g])); - Lib.add_anonymous_leaf (in_customs (g,ids,s)) - | _ -> error_constant g - - -let extract_inductive r (s,l) = - check_inside_section (); - let g = Nametab.global r in - match g with - | IndRef ((kn,i) as ip) -> - let mib = Global.lookup_mind kn in - let n = Array.length mib.mind_packets.(i).mind_consnames in - if n <> List.length l then error_nb_cons (); - Lib.add_anonymous_leaf (inline_extraction (true,[g])); - Lib.add_anonymous_leaf (in_customs (g,[],s)); - list_iter_i - (fun j s -> - let g = ConstructRef (ip,succ j) in - Lib.add_anonymous_leaf (inline_extraction (true,[g])); - Lib.add_anonymous_leaf (in_customs (g,[],s))) l - | _ -> error_inductive g - - - -(*s Tables synchronization. *) - -let reset_tables () = - init_terms (); init_types (); init_inductives (); init_recursors (); - init_projs (); init_axioms (); reset_modfile () diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli deleted file mode 100644 index 5ef7139e..00000000 --- a/contrib/extraction/table.mli +++ /dev/null @@ -1,151 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: table.mli 11844 2009-01-22 16:45:06Z letouzey $ i*) - -open Names -open Libnames -open Miniml -open Declarations - -val safe_id_of_global : global_reference -> identifier - -(*s Warning and Error messages. *) - -val warning_axioms : unit -> unit -val warning_both_mod_and_cst : - qualid -> module_path -> global_reference -> unit -val error_axiom_scheme : global_reference -> int -> 'a -val error_constant : global_reference -> 'a -val error_inductive : global_reference -> 'a -val error_nb_cons : unit -> 'a -val error_module_clash : string -> 'a -val error_unknown_module : qualid -> 'a -val error_scheme : unit -> 'a -val error_not_visible : global_reference -> 'a -val error_MPfile_as_mod : module_path -> bool -> 'a -val error_record : global_reference -> 'a -val check_inside_module : unit -> unit -val check_inside_section : unit -> unit -val check_loaded_modfile : module_path -> unit - -val info_file : string -> unit - -(*s utilities about [module_path] and [kernel_names] and [global_reference] *) - -val occur_kn_in_ref : kernel_name -> global_reference -> bool -val modpath_of_r : global_reference -> module_path -val label_of_r : global_reference -> label -val current_toplevel : unit -> module_path -val base_mp : module_path -> module_path -val is_modfile : module_path -> bool -val string_of_modfile : module_path -> string -val is_toplevel : module_path -> bool -val at_toplevel : module_path -> bool -val visible_kn : kernel_name -> bool -val visible_con : constant -> bool -val mp_length : module_path -> int -val prefixes_mp : module_path -> MPset.t -val modfile_of_mp : module_path -> module_path -val common_prefix_from_list : module_path -> module_path list -> module_path -val add_labels_mp : module_path -> label list -> module_path -val get_nth_label_mp : int -> module_path -> label -val labels_of_ref : global_reference -> module_path * label list - -(*s Some table-related operations *) - -val add_term : constant -> ml_decl -> unit -val lookup_term : constant -> ml_decl - -val add_type : constant -> ml_schema -> unit -val lookup_type : constant -> ml_schema - -val add_ind : kernel_name -> mutual_inductive_body -> ml_ind -> unit -val lookup_ind : kernel_name -> mutual_inductive_body * ml_ind - -val add_recursors : Environ.env -> kernel_name -> unit -val is_recursor : global_reference -> bool - -val add_projection : int -> constant -> unit -val is_projection : global_reference -> bool -val projection_arity : global_reference -> int - -val add_info_axiom : global_reference -> unit -val remove_info_axiom : global_reference -> unit -val add_log_axiom : global_reference -> unit - -val reset_tables : unit -> unit - -(*s AutoInline parameter *) - -val auto_inline : unit -> bool - -(*s TypeExpand parameter *) - -val type_expand : unit -> bool - -(*s Optimize parameter *) - -type opt_flag = - { opt_kill_dum : bool; (* 1 *) - opt_fix_fun : bool; (* 2 *) - opt_case_iot : bool; (* 4 *) - opt_case_idr : bool; (* 8 *) - opt_case_idg : bool; (* 16 *) - opt_case_cst : bool; (* 32 *) - opt_case_fun : bool; (* 64 *) - opt_case_app : bool; (* 128 *) - opt_let_app : bool; (* 256 *) - opt_lin_let : bool; (* 512 *) - opt_lin_beta : bool } (* 1024 *) - -val optims : unit -> opt_flag - -(*s Target language. *) - -type lang = Ocaml | Haskell | Scheme -val lang : unit -> lang - -(*s Extraction mode: modular or monolithic *) - -val set_modular : bool -> unit -val modular : unit -> bool - -(*s Table for custom inlining *) - -val to_inline : global_reference -> bool -val to_keep : global_reference -> bool - -(*s Table for user-given custom ML extractions. *) - -(* UGLY HACK: registration of a function defined in [extraction.ml] *) -val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit - -val is_custom : global_reference -> bool -val is_inline_custom : global_reference -> bool -val find_custom : global_reference -> string -val find_type_custom : global_reference -> string list * string - -(*s Extraction commands. *) - -val extraction_language : lang -> unit -val extraction_inline : bool -> reference list -> unit -val print_extraction_inline : unit -> unit -val reset_extraction_inline : unit -> unit -val extract_constant_inline : - bool -> reference -> string list -> string -> unit -val extract_inductive : reference -> string * string list -> unit - -(*s Table of blacklisted filenames *) - -val extraction_blacklist : identifier list -> unit -val reset_extraction_blacklist : unit -> unit -val print_extraction_blacklist : unit -> unit - - - diff --git a/contrib/field/LegacyField.v b/contrib/field/LegacyField.v deleted file mode 100644 index 08397d02..00000000 --- a/contrib/field/LegacyField.v +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *) - -Require Export LegacyField_Compl. -Require Export LegacyField_Theory. -Require Export LegacyField_Tactic. - -(* Command declarations are moved to the ML side *) diff --git a/contrib/field/LegacyField_Compl.v b/contrib/field/LegacyField_Compl.v deleted file mode 100644 index b37281e9..00000000 --- a/contrib/field/LegacyField_Compl.v +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *) - -Require Import List. - -Definition assoc_2nd := - (fix assoc_2nd_rec (A:Type) (B:Set) - (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2}) - (lst:list (prod A B)) {struct lst} : - B -> A -> A := - fun (key:B) (default:A) => - match lst with - | nil => default - | (v,e) :: l => - match eq_dec e key with - | left _ => v - | right _ => assoc_2nd_rec A B eq_dec l key default - end - end). - -Definition mem := - (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) - (a:A) (l:list A) {struct l} : bool := - match l with - | nil => false - | a1 :: l1 => - match eq_dec a a1 with - | left _ => true - | right _ => mem A eq_dec a l1 - end - end). diff --git a/contrib/field/LegacyField_Tactic.v b/contrib/field/LegacyField_Tactic.v deleted file mode 100644 index 2b6ff5b4..00000000 --- a/contrib/field/LegacyField_Tactic.v +++ /dev/null @@ -1,433 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *) - -Require Import List. -Require Import LegacyRing. -Require Export LegacyField_Compl. -Require Export LegacyField_Theory. - -(**** Interpretation A --> ExprA ****) - -Ltac get_component a s := eval cbv beta iota delta [a] in (a s). - -Ltac body_of s := eval cbv beta iota delta [s] in s. - -Ltac mem_assoc var lvar := - match constr:lvar with - | nil => constr:false - | ?X1 :: ?X2 => - match constr:(X1 = var) with - | (?X1 = ?X1) => constr:true - | _ => mem_assoc var X2 - end - end. - -Ltac number lvar := - let rec number_aux lvar cpt := - match constr:lvar with - | (@nil ?X1) => constr:(@nil (prod X1 nat)) - | ?X2 :: ?X3 => - let l2 := number_aux X3 (S cpt) in - constr:((X2,cpt) :: l2) - end - in number_aux lvar 0. - -Ltac build_varlist FT trm := - let rec seek_var lvar trm := - let AT := get_component A FT - with AzeroT := get_component Azero FT - with AoneT := get_component Aone FT - with AplusT := get_component Aplus FT - with AmultT := get_component Amult FT - with AoppT := get_component Aopp FT - with AinvT := get_component Ainv FT in - match constr:trm with - | AzeroT => lvar - | AoneT => lvar - | (AplusT ?X1 ?X2) => - let l1 := seek_var lvar X1 in - seek_var l1 X2 - | (AmultT ?X1 ?X2) => - let l1 := seek_var lvar X1 in - seek_var l1 X2 - | (AoppT ?X1) => seek_var lvar X1 - | (AinvT ?X1) => seek_var lvar X1 - | ?X1 => - let res := mem_assoc X1 lvar in - match constr:res with - | true => lvar - | false => constr:(X1 :: lvar) - end - end in - let AT := get_component A FT in - let lvar := seek_var (@nil AT) trm in - number lvar. - -Ltac assoc elt lst := - match constr:lst with - | nil => fail - | (?X1,?X2) :: ?X3 => - match constr:(elt = X1) with - | (?X1 = ?X1) => constr:X2 - | _ => assoc elt X3 - end - end. - -Ltac interp_A FT lvar trm := - let AT := get_component A FT - with AzeroT := get_component Azero FT - with AoneT := get_component Aone FT - with AplusT := get_component Aplus FT - with AmultT := get_component Amult FT - with AoppT := get_component Aopp FT - with AinvT := get_component Ainv FT in - match constr:trm with - | AzeroT => constr:EAzero - | AoneT => constr:EAone - | (AplusT ?X1 ?X2) => - let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in - constr:(EAplus e1 e2) - | (AmultT ?X1 ?X2) => - let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in - constr:(EAmult e1 e2) - | (AoppT ?X1) => - let e := interp_A FT lvar X1 in - constr:(EAopp e) - | (AinvT ?X1) => let e := interp_A FT lvar X1 in - constr:(EAinv e) - | ?X1 => let idx := assoc X1 lvar in - constr:(EAvar idx) - end. - -(************************) -(* Simplification *) -(************************) - -(**** Generation of the multiplier ****) - -Ltac remove e l := - match constr:l with - | nil => l - | e :: ?X2 => constr:X2 - | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl) - end. - -Ltac union l1 l2 := - match constr:l1 with - | nil => l2 - | ?X2 :: ?X3 => - let nl2 := remove X2 l2 in - let nl := union X3 nl2 in - constr:(X2 :: nl) - end. - -Ltac raw_give_mult trm := - match constr:trm with - | (EAinv ?X1) => constr:(X1 :: nil) - | (EAopp ?X1) => raw_give_mult X1 - | (EAplus ?X1 ?X2) => - let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in - union l1 l2 - | (EAmult ?X1 ?X2) => - let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in - eval compute in (app l1 l2) - | _ => constr:(@nil ExprA) - end. - -Ltac give_mult trm := - let ltrm := raw_give_mult trm in - constr:(mult_of_list ltrm). - -(**** Associativity ****) - -Ltac apply_assoc FT lvar trm := - let t := eval compute in (assoc trm) in - match constr:(t = trm) with - | (?X1 = ?X1) => idtac - | _ => - rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- * - end. - -(**** Distribution *****) - -Ltac apply_distrib FT lvar trm := - let t := eval compute in (distrib trm) in - match constr:(t = trm) with - | (?X1 = ?X1) => idtac - | _ => - rewrite <- (distrib_correct FT trm); - change (distrib trm) with t in |- * - end. - -(**** Multiplication by the inverse product ****) - -Ltac grep_mult := match goal with - | id:(interp_ExprA _ _ _ <> _) |- _ => id - end. - -Ltac weak_reduce := - match goal with - | |- context [(interp_ExprA ?X1 ?X2 _)] => - cbv beta iota zeta - delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero - Aone Aplus Amult Aopp Ainv] in |- * - end. - -Ltac multiply mul := - match goal with - | |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) => - let AzeroT := get_component Azero FT in - cut (interp_ExprA FT X2 mul <> AzeroT); - [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id)) - | weak_reduce; - (let AoneT := get_component Aone ltac:(body_of FT) - with AmultT := get_component Amult ltac:(body_of FT) in - try - match goal with - | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT) - end; clear FT X2) ] - end. - -Ltac apply_multiply FT lvar trm := - let t := eval compute in (multiply trm) in - match constr:(t = trm) with - | (?X1 = ?X1) => idtac - | _ => - rewrite <- (multiply_correct FT trm); - change (multiply trm) with t in |- * - end. - -(**** Permutations and simplification ****) - -Ltac apply_inverse mul FT lvar trm := - let t := eval compute in (inverse_simplif mul trm) in - match constr:(t = trm) with - | (?X1 = ?X1) => idtac - | _ => - rewrite <- (inverse_correct FT trm mul); - [ change (inverse_simplif mul trm) with t in |- * | assumption ] - end. -(**** Inverse test ****) - -Ltac strong_fail tac := first [ tac | fail 2 ]. - -Ltac inverse_test_aux FT trm := - let AplusT := get_component Aplus FT - with AmultT := get_component Amult FT - with AoppT := get_component Aopp FT - with AinvT := get_component Ainv FT in - match constr:trm with - | (AinvT _) => fail 1 - | (AoppT ?X1) => - strong_fail ltac:(inverse_test_aux FT X1; idtac) - | (AplusT ?X1 ?X2) => - strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) - | (AmultT ?X1 ?X2) => - strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) - | _ => idtac - end. - -Ltac inverse_test FT := - let AplusT := get_component Aplus FT in - match goal with - | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2) - end. - -(**** Field itself ****) - -Ltac apply_simplif sfun := - match goal with - | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => - sfun X1 X2 X3 - end; - match goal with - | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => - sfun X1 X2 X3 - end. - -Ltac unfolds FT := - match get_component Aminus FT with - | Some ?X1 => unfold X1 in |- * - | _ => idtac - end; - match get_component Adiv FT with - | Some ?X1 => unfold X1 in |- * - | _ => idtac - end. - -Ltac reduce FT := - let AzeroT := get_component Azero FT - with AoneT := get_component Aone FT - with AplusT := get_component Aplus FT - with AmultT := get_component Amult FT - with AoppT := get_component Aopp FT - with AinvT := get_component Ainv FT in - (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * || - compute in |- *). - -Ltac field_gen_aux FT := - let AplusT := get_component Aplus FT in - match goal with - | |- (?X1 = ?X2) => - let lvar := build_varlist FT (AplusT X1 X2) in - let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in - let mul := give_mult (EAplus trm1 trm2) in - cut - (let ft := FT in - let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); - [ compute in |- *; auto - | intros ft vm; apply_simplif apply_distrib; - apply_simplif apply_assoc; multiply mul; - [ apply_simplif apply_multiply; - apply_simplif ltac:(apply_inverse mul); - (let id := grep_mult in - clear id; weak_reduce; clear ft vm; first - [ inverse_test FT; legacy ring | field_gen_aux FT ]) - | idtac ] ] - end. - -Ltac field_gen FT := - unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT. - -(*****************************) -(* Term Simplification *) -(*****************************) - -(**** Minus and division expansions ****) - -Ltac init_exp FT trm := - let e := - (match get_component Aminus FT with - | Some ?X1 => eval cbv beta delta [X1] in trm - | _ => trm - end) in - match get_component Adiv FT with - | Some ?X1 => eval cbv beta delta [X1] in e - | _ => e - end. - -(**** Inverses simplification ****) - -Ltac simpl_inv trm := - match constr:trm with - | (EAplus ?X1 ?X2) => - let e1 := simpl_inv X1 with e2 := simpl_inv X2 in - constr:(EAplus e1 e2) - | (EAmult ?X1 ?X2) => - let e1 := simpl_inv X1 with e2 := simpl_inv X2 in - constr:(EAmult e1 e2) - | (EAopp ?X1) => let e := simpl_inv X1 in - constr:(EAopp e) - | (EAinv ?X1) => SimplInvAux X1 - | ?X1 => constr:X1 - end - with SimplInvAux trm := - match constr:trm with - | (EAinv ?X1) => simpl_inv X1 - | (EAmult ?X1 ?X2) => - let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in - constr:(EAmult e1 e2) - | ?X1 => let e := simpl_inv X1 in - constr:(EAinv e) - end. - -(**** Monom simplification ****) - -Ltac map_tactic fcn lst := - match constr:lst with - | nil => lst - | ?X2 :: ?X3 => - let r := fcn X2 with t := map_tactic fcn X3 in - constr:(r :: t) - end. - -Ltac build_monom_aux lst trm := - match constr:lst with - | nil => eval compute in (assoc trm) - | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1) - end. - -Ltac build_monom lnum lden := - let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in - let ltot := eval compute in (app lnum ildn) in - let trm := build_monom_aux ltot EAone in - match constr:trm with - | (EAmult _ ?X1) => constr:X1 - | ?X1 => constr:X1 - end. - -Ltac simpl_monom_aux lnum lden trm := - match constr:trm with - | (EAmult (EAinv ?X1) ?X2) => - let mma := mem_assoc X1 lnum in - match constr:mma with - | true => - let newlnum := remove X1 lnum in - simpl_monom_aux newlnum lden X2 - | false => simpl_monom_aux lnum (X1 :: lden) X2 - end - | (EAmult ?X1 ?X2) => - let mma := mem_assoc X1 lden in - match constr:mma with - | true => - let newlden := remove X1 lden in - simpl_monom_aux lnum newlden X2 - | false => simpl_monom_aux (X1 :: lnum) lden X2 - end - | (EAinv ?X1) => - let mma := mem_assoc X1 lnum in - match constr:mma with - | true => - let newlnum := remove X1 lnum in - build_monom newlnum lden - | false => build_monom lnum (X1 :: lden) - end - | ?X1 => - let mma := mem_assoc X1 lden in - match constr:mma with - | true => - let newlden := remove X1 lden in - build_monom lnum newlden - | false => build_monom (X1 :: lnum) lden - end - end. - -Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm. - -Ltac simpl_all_monomials trm := - match constr:trm with - | (EAplus ?X1 ?X2) => - let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in - constr:(EAplus e1 e2) - | ?X1 => simpl_monom X1 - end. - -(**** Associativity and distribution ****) - -Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)). - -(**** The tactic Field_Term ****) - -Ltac eval_weak_reduce trm := - eval - cbv beta iota zeta - delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus - Amult Aopp Ainv] in trm. - -Ltac field_term FT exp := - let newexp := init_exp FT exp in - let lvar := build_varlist FT newexp in - let trm := interp_A FT lvar newexp in - let tma := eval compute in (assoc trm) in - let tsmp := - simpl_all_monomials - ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in - let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in - (replace exp with trep; [ legacy ring trep | field_gen FT ]). diff --git a/contrib/field/LegacyField_Theory.v b/contrib/field/LegacyField_Theory.v deleted file mode 100644 index 9c3a12fb..00000000 --- a/contrib/field/LegacyField_Theory.v +++ /dev/null @@ -1,650 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *) - -Require Import List. -Require Import Peano_dec. -Require Import LegacyRing. -Require Import LegacyField_Compl. - -Record Field_Theory : Type := - {A : Type; - Aplus : A -> A -> A; - Amult : A -> A -> A; - Aone : A; - Azero : A; - Aopp : A -> A; - Aeq : A -> A -> bool; - Ainv : A -> A; - Aminus : option (A -> A -> A); - Adiv : option (A -> A -> A); - RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq; - Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}. - -(* The reflexion structure *) -Inductive ExprA : Set := - | EAzero : ExprA - | EAone : ExprA - | EAplus : ExprA -> ExprA -> ExprA - | EAmult : ExprA -> ExprA -> ExprA - | EAopp : ExprA -> ExprA - | EAinv : ExprA -> ExprA - | EAvar : nat -> ExprA. - -(**** Decidability of equality ****) - -Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}. -Proof. - double induction e1 e2; try intros; - try (left; reflexivity) || (try (right; discriminate)). - elim (H1 e0); intro y; elim (H2 e); intro y0; - try - (left; rewrite y; rewrite y0; auto) || - (right; red in |- *; intro; inversion H3; auto). - elim (H1 e0); intro y; elim (H2 e); intro y0; - try - (left; rewrite y; rewrite y0; auto) || - (right; red in |- *; intro; inversion H3; auto). - elim (H0 e); intro y. - left; rewrite y; auto. - right; red in |- *; intro; inversion H1; auto. - elim (H0 e); intro y. - left; rewrite y; auto. - right; red in |- *; intro; inversion H1; auto. - elim (eq_nat_dec n n0); intro y. - left; rewrite y; auto. - right; red in |- *; intro; inversion H; auto. -Defined. - -Definition eq_nat_dec := Eval compute in eq_nat_dec. -Definition eqExprA := Eval compute in eqExprA_O. - -(**** Generation of the multiplier ****) - -Fixpoint mult_of_list (e:list ExprA) : ExprA := - match e with - | nil => EAone - | e1 :: l1 => EAmult e1 (mult_of_list l1) - end. - -Section Theory_of_fields. - -Variable T : Field_Theory. - -Let AT := A T. -Let AplusT := Aplus T. -Let AmultT := Amult T. -Let AoneT := Aone T. -Let AzeroT := Azero T. -Let AoppT := Aopp T. -Let AeqT := Aeq T. -Let AinvT := Ainv T. -Let RTT := RT T. -Let Th_inv_defT := Th_inv_def T. - -Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( - Azero T) (Aopp T) (Aeq T) (RT T). - -Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. - -(***************************) -(* Lemmas to be used *) -(***************************) - -Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. -Proof. - intros; legacy ring. -Qed. - -Lemma AplusT_assoc : - forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). -Proof. - intros; legacy ring. -Qed. - -Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. -Proof. - intros; legacy ring. -Qed. - -Lemma AmultT_assoc : - forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). -Proof. - intros; legacy ring. -Qed. - -Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. -Proof. - intros; legacy ring. -Qed. - -Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. -Proof. - intros; legacy ring. -Qed. - -Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. -Proof. - intros; legacy ring. -Qed. - -Lemma AmultT_AplusT_distr : - forall r1 r2 r3:AT, - AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3). -Proof. - intros; legacy ring. -Qed. - -Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2. -Proof. - intros; transitivity (AplusT (AplusT (AoppT r) r) r1). - legacy ring. - transitivity (AplusT (AplusT (AoppT r) r) r2). - repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. - legacy ring. -Qed. - -Lemma r_AmultT_mult : - forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. -Proof. - intros; transitivity (AmultT (AmultT (AinvT r) r) r1). - rewrite Th_inv_defT; [ symmetry in |- *; apply AmultT_1l; auto | auto ]. - transitivity (AmultT (AmultT (AinvT r) r) r2). - repeat rewrite AmultT_assoc; rewrite H; trivial. - rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ]. -Qed. - -Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. -Proof. - intro; legacy ring. -Qed. - -Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. -Proof. - intro; legacy ring. -Qed. - -Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. -Proof. - intro; legacy ring. -Qed. - -Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. -Proof. - intros; rewrite AmultT_comm; apply Th_inv_defT; auto. -Qed. - -Lemma Rmult_neq_0_reg : - forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. -Proof. - intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring. -Qed. - -(************************) -(* Interpretation *) -(************************) - -(**** ExprA --> A ****) - -Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} : - AT := - match e with - | EAzero => AzeroT - | EAone => AoneT - | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2) - | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2) - | EAopp e => Aopp T (interp_ExprA lvar e) - | EAinv e => Ainv T (interp_ExprA lvar e) - | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT - end. - -(************************) -(* Simplification *) -(************************) - -(**** Associativity ****) - -Definition merge_mult := - (fix merge_mult (e1:ExprA) : ExprA -> ExprA := - fun e2:ExprA => - match e1 with - | EAmult t1 t2 => - match t2 with - | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2)) - | _ => EAmult t1 (EAmult t2 e2) - end - | _ => EAmult e1 e2 - end). - -Fixpoint assoc_mult (e:ExprA) : ExprA := - match e with - | EAmult e1 e3 => - match e1 with - | EAmult e1 e2 => - merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2)) - (assoc_mult e3) - | _ => EAmult e1 (assoc_mult e3) - end - | _ => e - end. - -Definition merge_plus := - (fix merge_plus (e1:ExprA) : ExprA -> ExprA := - fun e2:ExprA => - match e1 with - | EAplus t1 t2 => - match t2 with - | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2)) - | _ => EAplus t1 (EAplus t2 e2) - end - | _ => EAplus e1 e2 - end). - -Fixpoint assoc (e:ExprA) : ExprA := - match e with - | EAplus e1 e3 => - match e1 with - | EAplus e1 e2 => - merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3) - | _ => EAplus (assoc_mult e1) (assoc e3) - end - | _ => assoc_mult e - end. - -Lemma merge_mult_correct1 : - forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) = - interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)). -Proof. -intros e1 e2; generalize e1; generalize e2; clear e1 e2. -simple induction e2; auto; intros. -unfold merge_mult at 1 in |- *; fold merge_mult in |- *; - unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; - fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; - fold interp_ExprA in |- *; auto. -Qed. - -Lemma merge_mult_correct : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). -Proof. -simple induction e1; auto; intros. -elim e0; try (intros; simpl in |- *; legacy ring). -unfold interp_ExprA in H2; fold interp_ExprA in H2; - cut - (AmultT (interp_ExprA lvar e2) - (AmultT (interp_ExprA lvar e4) - (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = - AmultT - (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) - (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). -intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1; - simpl in |- *; legacy ring. -legacy ring. -Qed. - -Lemma assoc_mult_correct1 : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - AmultT (interp_ExprA lvar (assoc_mult e1)) - (interp_ExprA lvar (assoc_mult e2)) = - interp_ExprA lvar (assoc_mult (EAmult e1 e2)). -Proof. -simple induction e1; auto; intros. -rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; - simpl in |- *; rewrite merge_mult_correct; simpl in |- *; - auto. -Qed. - -Lemma assoc_mult_correct : - forall (e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e. -Proof. -simple induction e; auto; intros. -elim e0; intros. -intros; simpl in |- *; legacy ring. -simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); - rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite merge_mult_correct; simpl in |- *; - rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc; - rewrite assoc_mult_correct1; rewrite H2; simpl in |- *; - rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; - fold interp_ExprA in H1; rewrite (H0 lvar) in H1; - rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); - rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; - legacy ring. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -Qed. - -Lemma merge_plus_correct1 : - forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) = - interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)). -Proof. -intros e1 e2; generalize e1; generalize e2; clear e1 e2. -simple induction e2; auto; intros. -unfold merge_plus at 1 in |- *; fold merge_plus in |- *; - unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; - fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; - fold interp_ExprA in |- *; auto. -Qed. - -Lemma merge_plus_correct : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). -Proof. -simple induction e1; auto; intros. -elim e0; try intros; try (simpl in |- *; legacy ring). -unfold interp_ExprA in H2; fold interp_ExprA in H2; - cut - (AplusT (interp_ExprA lvar e2) - (AplusT (interp_ExprA lvar e4) - (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = - AplusT - (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) - (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). -intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1; - simpl in |- *; legacy ring. -legacy ring. -Qed. - -Lemma assoc_plus_correct : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) = - interp_ExprA lvar (assoc (EAplus e1 e2)). -Proof. -simple induction e1; auto; intros. -rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; - simpl in |- *; rewrite merge_plus_correct; simpl in |- *; - auto. -Qed. - -Lemma assoc_correct : - forall (e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (assoc e) = interp_ExprA lvar e. -Proof. -simple induction e; auto; intros. -elim e0; intros. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite merge_plus_correct; simpl in |- *; - rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc; - rewrite assoc_plus_correct; rewrite H2; simpl in |- *; - apply - (r_AplusT_plus (interp_ExprA lvar (assoc e1)) - (AplusT (interp_ExprA lvar (assoc e2)) - (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1))) - (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) - (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; - rewrite - (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) - ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; - rewrite (H0 lvar); - rewrite <- - (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) - (interp_ExprA lvar e3) (interp_ExprA lvar e1)) - ; - rewrite - (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) - (interp_ExprA lvar e3)); - rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3)); - rewrite <- - (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) - (interp_ExprA lvar e1)); apply AplusT_comm. -unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; - rewrite (H0 lvar); simpl in |- *; auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; - simpl in |- *; auto. -Qed. - -(**** Distribution *****) - -Fixpoint distrib_EAopp (e:ExprA) : ExprA := - match e with - | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2) - | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2) - | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e) - | e => e - end. - -Definition distrib_mult_right := - (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA := - fun e2:ExprA => - match e1 with - | EAplus t1 t2 => - EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2) - | _ => EAmult e1 e2 - end). - -Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA := - match e1 with - | EAplus t1 t2 => - EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2) - | _ => distrib_mult_right e2 e1 - end. - -Fixpoint distrib_main (e:ExprA) : ExprA := - match e with - | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2) - | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2) - | EAopp e => EAopp (distrib_main e) - | _ => e - end. - -Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). - -Lemma distrib_mult_right_correct : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (distrib_mult_right e1 e2) = - AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). -Proof. -simple induction e1; try intros; simpl in |- *; auto. -rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); - rewrite (H0 e2 lvar); legacy ring. -Qed. - -Lemma distrib_mult_left_correct : - forall (e1 e2:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (distrib_mult_left e1 e2) = - AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). -Proof. -simple induction e1; try intros; simpl in |- *. -rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; - apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite AmultT_comm; - rewrite - (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) - (interp_ExprA lvar e0)); - rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e)); - rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0)); - rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -Qed. - -Lemma distrib_correct : - forall (e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (distrib e) = interp_ExprA lvar e. -Proof. -simple induction e; intros; auto. -simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib in |- *; simpl in |- *; auto. -simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct. -simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar); - unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct; - simpl in |- *; fold AoppT in |- *; legacy ring. -Qed. - -(**** Multiplication by the inverse product ****) - -Lemma mult_eq : - forall (e1 e2 a:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar a <> AzeroT -> - interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> - interp_ExprA lvar e1 = interp_ExprA lvar e2. -Proof. - simpl in |- *; intros; - apply - (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1) - (interp_ExprA lvar e2)); assumption. -Qed. - -Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA := - match e with - | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2) - | _ => EAmult a e - end. - -Definition multiply (e:ExprA) : ExprA := - match e with - | EAmult a e1 => multiply_aux a e1 - | _ => e - end. - -Lemma multiply_aux_correct : - forall (a e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (multiply_aux a e) = - AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). -Proof. -simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; - auto. - simpl in |- *; rewrite (H0 lvar); legacy ring. -Qed. - -Lemma multiply_correct : - forall (e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar (multiply e) = interp_ExprA lvar e. -Proof. - simple induction e; simpl in |- *; auto. - intros; apply multiply_aux_correct. -Qed. - -(**** Permutations and simplification ****) - -Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA := - match m with - | EAmult m0 m1 => - match eqExprA m0 (EAinv a) with - | left _ => m1 - | right _ => EAmult m0 (monom_remove a m1) - end - | _ => - match eqExprA m (EAinv a) with - | left _ => EAone - | right _ => EAmult a m - end - end. - -Definition monom_simplif_rem := - (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA := - fun m:ExprA => - match a with - | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m) - | _ => monom_remove a m - end). - -Definition monom_simplif (a m:ExprA) : ExprA := - match m with - | EAmult a' m' => - match eqExprA a a' with - | left _ => monom_simplif_rem a m' - | right _ => m - end - | _ => m - end. - -Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := - match e with - | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2) - | _ => monom_simplif a e - end. - -Lemma monom_remove_correct : - forall (e a:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar a <> AzeroT -> - interp_ExprA lvar (monom_remove a e) = - AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). -Proof. -simple induction e; intros. -simpl in |- *; case (eqExprA EAzero (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA EAone (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; - [ inversion e2 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA e0 (EAinv a)); intros. -rewrite e2; simpl in |- *; fold AinvT in |- *. -rewrite <- - (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) - (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. -simpl in |- *; rewrite H0; auto; legacy ring. -simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a)); - intros; [ inversion e1 | simpl in |- *; trivial ]. -unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros. -case (eqExprA e0 a); intros. -rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto. -inversion e1; simpl in |- *; elimtype False; auto. -simpl in |- *; trivial. -unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. -Qed. - -Lemma monom_simplif_rem_correct : - forall (a e:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar a <> AzeroT -> - interp_ExprA lvar (monom_simplif_rem a e) = - AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). -Proof. -simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; - auto. -elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); - intros. -rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto. -legacy ring. -Qed. - -Lemma monom_simplif_correct : - forall (e a:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar a <> AzeroT -> - interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. -Proof. -simple induction e; intros; auto. -simpl in |- *; case (eqExprA a e0); intros. -rewrite <- e2; apply monom_simplif_rem_correct; auto. -simpl in |- *; trivial. -Qed. - -Lemma inverse_correct : - forall (e a:ExprA) (lvar:list (AT * nat)), - interp_ExprA lvar a <> AzeroT -> - interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. -Proof. -simple induction e; intros; auto. -simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. -unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. -Qed. - -End Theory_of_fields. - -(* Compatibility *) -Notation AplusT_sym := AplusT_comm (only parsing). -Notation AmultT_sym := AmultT_comm (only parsing). diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 deleted file mode 100644 index dea79773..00000000 --- a/contrib/field/field.ml4 +++ /dev/null @@ -1,193 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *) - -open Names -open Pp -open Proof_type -open Tacinterp -open Tacmach -open Term -open Typing -open Util -open Vernacinterp -open Vernacexpr -open Tacexpr -open Mod_subst -open Coqlib - -(* Interpretation of constr's *) -let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c - -(* Construction of constants *) -let constant dir s = gen_constant "Field" ("field"::dir) s -let init_constant s = gen_constant_in_modules "Field" init_modules s - -(* To deal with the optional arguments *) -let constr_of_opt a opt = - let ac = constr_of a in - let ac3 = mkArrow ac (mkArrow ac ac) in - match opt with - | None -> mkApp (init_constant "None",[|ac3|]) - | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) - -(* Table of theories *) -let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) - -let lookup env typ = - try Gmap.find typ !th_tab - with Not_found -> - errorlabstrm "field" - (str "No field is declared for type" ++ spc() ++ - Printer.pr_lconstr_env env typ) - -let _ = - let init () = th_tab := Gmap.empty in - let freeze () = !th_tab in - let unfreeze fs = th_tab := fs in - Summary.declare_summary "field" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } - -let load_addfield _ = () -let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab -let subst_addfield (_,subst,(typ,th as obj)) = - let typ' = subst_mps subst typ in - let th' = subst_mps subst th in - if typ' == typ && th' == th then obj else - (typ',th') -let export_addfield x = Some x - -(* Declaration of the Add Field library object *) -let (in_addfield,out_addfield)= - Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with - Libobject.open_function = (fun i o -> if i=1 then cache_addfield o); - Libobject.cache_function = cache_addfield; - Libobject.subst_function = subst_addfield; - Libobject.classify_function = (fun (_,a) -> Libobject.Substitute a); - Libobject.export_function = export_addfield } - -(* Adds a theory to the table *) -let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth - ainv_l = - begin - (try - Ring.add_theory true true false a None None None aplus amult aone azero - (Some aopp) aeq rth Quote.ConstrSet.empty - with | UserError("Add Semi Ring",_) -> ()); - let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"), - [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in - begin - let _ = type_of (Global.env ()) Evd.empty th in (); - Lib.add_anonymous_leaf (in_addfield (a,th)) - end - end - -(* Vernac command declaration *) -open Extend -open Pcoq -open Genarg - -VERNAC ARGUMENT EXTEND divarg -| [ "div" ":=" constr(adiv) ] -> [ adiv ] -END - -VERNAC ARGUMENT EXTEND minusarg -| [ "minus" ":=" constr(aminus) ] -> [ aminus ] -END - -(* -(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*) -VERNAC ARGUMENT EXTEND minus_div_arg -| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] -| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] -| [ ] -> [ None, None ] -END -*) - -(* For the translator, otherwise the code above is OK *) -open Ppconstr -let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = - if omin=None && odiv=None then mt() else - spc() ++ str "with" ++ - pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ - pr_opt (fun c -> str "div := " ++ _prc c) odiv -(* -let () = - Pptactic.declare_extra_genarg_pprule true - (rawwit_minus_div_arg,pp_minus_div_arg) - (globwit_minus_div_arg,pp_minus_div_arg) - (wit_minus_div_arg,pp_minus_div_arg) -*) -ARGUMENT EXTEND minus_div_arg - TYPED AS constr_opt * constr_opt - PRINTED BY pp_minus_div_arg -| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] -| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] -| [ ] -> [ None, None ] -END - -VERNAC COMMAND EXTEND Field - [ "Add" "Legacy" "Field" - constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aopp) constr(aeq) - constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] - -> [ let (aminus_o, adiv_o) = md in - add_field - (constr_of a) (constr_of aplus) (constr_of amult) - (constr_of aone) (constr_of azero) (constr_of aopp) - (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o) - (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ] -END - -(* Guesses the type and calls field_gen with the right theory *) -let field g = - Coqlib.check_required_library ["Coq";"field";"LegacyField"]; - let typ = - match Hipattern.match_with_equation (pf_concl g) with - | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t - | _ -> error "The statement is not built from Leibniz' equality" in - let th = VConstr (lookup (pf_env g) typ) in - (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ()) - <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g - -(* Verifies that all the terms have the same type and gives the right theory *) -let guess_theory env evc = function - | c::tl -> - let t = type_of env evc c in - if List.exists (fun c1 -> - not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then - errorlabstrm "Field:" (str" All the terms must have the same type") - else - lookup env t - | [] -> anomaly "Field: must have a non-empty constr list here" - -(* Guesses the type and calls Field_Term with the right theory *) -let field_term l g = - Coqlib.check_required_library ["Coq";"field";"LegacyField"]; - let env = (pf_env g) - and evc = (project g) in - let th = valueIn (VConstr (guess_theory env evc l)) - and nl = List.map (fun x -> valueIn (VConstr x)) (Quote.sort_subterm g l) in - (List.fold_right - (fun c a -> - let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in - Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g - -(* Declaration of Field *) - -TACTIC EXTEND legacy_field -| [ "legacy" "field" ] -> [ field ] -| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ] -END diff --git a/contrib/firstorder/formula.ml b/contrib/firstorder/formula.ml deleted file mode 100644 index 3e49cd9c..00000000 --- a/contrib/firstorder/formula.ml +++ /dev/null @@ -1,270 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *) - -open Hipattern -open Names -open Term -open Termops -open Reductionops -open Tacmach -open Util -open Declarations -open Libnames -open Inductiveops - -let qflag=ref true - -let red_flags=ref Closure.betaiotazeta - -let (=?) f g i1 i2 j1 j2= - let c=f i1 i2 in - if c=0 then g j1 j2 else c - -let (==?) fg h i1 i2 j1 j2 k1 k2= - let c=fg i1 i2 j1 j2 in - if c=0 then h k1 k2 else c - -type ('a,'b) sum = Left of 'a | Right of 'b - -type counter = bool -> metavariable - -exception Is_atom of constr - -let meta_succ m = m+1 - -let rec nb_prod_after n c= - match kind_of_term c with - | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else - 1+(nb_prod_after 0 b) - | _ -> 0 - -let construct_nhyps ind gls = - let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in - let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in - let hyp = nb_prod_after nparams in - Array.map hyp constr_types - -(* indhyps builds the array of arrays of constructor hyps for (ind largs)*) -let ind_hyps nevar ind largs gls= - let types= Inductiveops.arities_of_constructors (pf_env gls) ind in - let lp=Array.length types in - let myhyps i= - let t1=Term.prod_applist types.(i) largs in - let t2=snd (Sign.decompose_prod_n_assum nevar t1) in - fst (Sign.decompose_prod_assum t2) in - Array.init lp myhyps - -let special_nf gl= - let infos=Closure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) - -let special_whd gl= - let infos=Closure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -type kind_of_formula= - Arrow of constr*constr - | False of inductive*constr list - | And of inductive*constr list*bool - | Or of inductive*constr list*bool - | Exists of inductive*constr list - | Forall of constr*constr - | Atom of constr - -let rec kind_of_formula gl term = - let normalize=special_nf gl in - let cciterm=special_whd gl term in - match match_with_imp_term cciterm with - Some (a,b)-> Arrow(a,(pop b)) - |_-> - match match_with_forall_term cciterm with - Some (_,a,b)-> Forall(a,b) - |_-> - match match_with_nodep_ind cciterm with - Some (i,l,n)-> - let ind=destInd i in - let (mib,mip) = Global.lookup_inductive ind in - let nconstr=Array.length mip.mind_consnames in - if nconstr=0 then - False(ind,l) - else - let has_realargs=(n>0) in - let is_trivial= - let is_constant c = - nb_prod c = mib.mind_nparams in - array_exists is_constant mip.mind_nf_lc in - if Inductiveops.mis_is_recursive (ind,mib,mip) || - (has_realargs && not is_trivial) - then - Atom cciterm - else - if nconstr=1 then - And(ind,l,is_trivial) - else - Or(ind,l,is_trivial) - | _ -> - match match_with_sigma_type cciterm with - Some (i,l)-> Exists((destInd i),l) - |_-> Atom (normalize cciterm) - -type atoms = {positive:constr list;negative:constr list} - -type side = Hyp | Concl | Hint - -let no_atoms = (false,{positive=[];negative=[]}) - -let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *) - -let build_atoms gl metagen side cciterm = - let trivial =ref false - and positive=ref [] - and negative=ref [] in - let normalize=special_nf gl in - let rec build_rec env polarity cciterm= - match kind_of_formula gl cciterm with - False(_,_)->if not polarity then trivial:=true - | Arrow (a,b)-> - build_rec env (not polarity) a; - build_rec env polarity b - | And(i,l,b) | Or(i,l,b)-> - if b then - begin - let unsigned=normalize (substnl env 0 cciterm) in - if polarity then - positive:= unsigned :: !positive - else - negative:= unsigned :: !negative - end; - let v = ind_hyps 0 i l gl in - let g i _ (_,_,t) = - build_rec env polarity (lift i t) in - let f l = - list_fold_left_i g (1-(List.length l)) () l in - if polarity && (* we have a constant constructor *) - array_exists (function []->true|_->false) v - then trivial:=true; - Array.iter f v - | Exists(i,l)-> - let var=mkMeta (metagen true) in - let v =(ind_hyps 1 i l gl).(0) in - let g i _ (_,_,t) = - build_rec (var::env) polarity (lift i t) in - list_fold_left_i g (2-(List.length l)) () v - | Forall(_,b)-> - let var=mkMeta (metagen true) in - build_rec (var::env) polarity b - | Atom t-> - let unsigned=substnl env 0 t in - if not (isMeta unsigned) then (* discarding wildcard atoms *) - if polarity then - positive:= unsigned :: !positive - else - negative:= unsigned :: !negative in - begin - match side with - Concl -> build_rec [] true cciterm - | Hyp -> build_rec [] false cciterm - | Hint -> - let rels,head=decompose_prod cciterm in - let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in - build_rec env false head;trivial:=false (* special for hints *) - end; - (!trivial, - {positive= !positive; - negative= !negative}) - -type right_pattern = - Rarrow - | Rand - | Ror - | Rfalse - | Rforall - | Rexists of metavariable*constr*bool - -type left_arrow_pattern= - LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list - | LLforall of constr - | LLexists of inductive*constr list - | LLarrow of constr*constr*constr - -type left_pattern= - Lfalse - | Land of inductive - | Lor of inductive - | Lforall of metavariable*constr*bool - | Lexists of inductive - | LA of constr*left_arrow_pattern - -type t={id:global_reference; - constr:constr; - pat:(left_pattern,right_pattern) sum; - atoms:atoms} - -let build_formula side nam typ gl metagen= - let normalize = special_nf gl in - try - let m=meta_succ(metagen false) in - let trivial,atoms= - if !qflag then - build_atoms gl metagen side typ - else no_atoms in - let pattern= - match side with - Concl -> - let pat= - match kind_of_formula gl typ with - False(_,_) -> Rfalse - | Atom a -> raise (Is_atom a) - | And(_,_,_) -> Rand - | Or(_,_,_) -> Ror - | Exists (i,l) -> - let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in - Rexists(m,d,trivial) - | Forall (_,a) -> Rforall - | Arrow (a,b) -> Rarrow in - Right pat - | _ -> - let pat= - match kind_of_formula gl typ with - False(i,_) -> Lfalse - | Atom a -> raise (Is_atom a) - | And(i,_,b) -> - if b then - let nftyp=normalize typ in raise (Is_atom nftyp) - else Land i - | Or(i,_,b) -> - if b then - let nftyp=normalize typ in raise (Is_atom nftyp) - else Lor i - | Exists (ind,_) -> Lexists ind - | Forall (d,_) -> - Lforall(m,d,trivial) - | Arrow (a,b) -> - let nfa=normalize a in - LA (nfa, - match kind_of_formula gl a with - False(i,l)-> LLfalse(i,l) - | Atom t-> LLatom - | And(i,l,_)-> LLand(i,l) - | Or(i,l,_)-> LLor(i,l) - | Arrow(a,c)-> LLarrow(a,c,b) - | Exists(i,l)->LLexists(i,l) - | Forall(_,_)->LLforall a) in - Left pat - in - Left {id=nam; - constr=normalize typ; - pat=pattern; - atoms=atoms} - with Is_atom a-> Right a (* already in nf *) - diff --git a/contrib/firstorder/formula.mli b/contrib/firstorder/formula.mli deleted file mode 100644 index 8703045c..00000000 --- a/contrib/firstorder/formula.mli +++ /dev/null @@ -1,77 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: formula.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term -open Names -open Libnames - -val qflag : bool ref - -val red_flags: Closure.RedFlags.reds ref - -val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> - 'a -> 'a -> 'b -> 'b -> int - -val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> - 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int - -type ('a,'b) sum = Left of 'a | Right of 'b - -type counter = bool -> metavariable - -val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array - -val ind_hyps : int -> inductive -> constr list -> - Proof_type.goal Tacmach.sigma -> Sign.rel_context array - -type atoms = {positive:constr list;negative:constr list} - -type side = Hyp | Concl | Hint - -val dummy_id: global_reference - -val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> - side -> constr -> bool * atoms - -type right_pattern = - Rarrow - | Rand - | Ror - | Rfalse - | Rforall - | Rexists of metavariable*constr*bool - -type left_arrow_pattern= - LLatom - | LLfalse of inductive*constr list - | LLand of inductive*constr list - | LLor of inductive*constr list - | LLforall of constr - | LLexists of inductive*constr list - | LLarrow of constr*constr*constr - -type left_pattern= - Lfalse - | Land of inductive - | Lor of inductive - | Lforall of metavariable*constr*bool - | Lexists of inductive - | LA of constr*left_arrow_pattern - -type t={id: global_reference; - constr: constr; - pat: (left_pattern,right_pattern) sum; - atoms: atoms} - -(*exception Is_atom of constr*) - -val build_formula : side -> global_reference -> types -> - Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum - diff --git a/contrib/firstorder/g_ground.ml4 b/contrib/firstorder/g_ground.ml4 deleted file mode 100644 index f7b0a546..00000000 --- a/contrib/firstorder/g_ground.ml4 +++ /dev/null @@ -1,128 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *) - -open Formula -open Sequent -open Ground -open Goptions -open Tactics -open Tacticals -open Tacinterp -open Term -open Names -open Util -open Libnames - -(* declaring search depth as a global option *) - -let ground_depth=ref 3 - -let _= - let gdopt= - { optsync=true; - optname="Firstorder Depth"; - optkey=SecondaryTable("Firstorder","Depth"); - optread=(fun ()->Some !ground_depth); - optwrite= - (function - None->ground_depth:=3 - | Some i->ground_depth:=(max i 0))} - in - declare_int_option gdopt - -let congruence_depth=ref 100 - -let _= - let gdopt= - { optsync=true; - optname="Congruence Depth"; - optkey=SecondaryTable("Congruence","Depth"); - optread=(fun ()->Some !congruence_depth); - optwrite= - (function - None->congruence_depth:=0 - | Some i->congruence_depth:=(max i 0))} - in - declare_int_option gdopt - -let default_solver=(Tacinterp.interp <:tactic<auto with *>>) - -let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") - -type external_env= - Ids of global_reference list - | Bases of Auto.hint_db_name list - | Void - -let gen_ground_tac flag taco ext gl= - let backup= !qflag in - try - qflag:=flag; - let solver= - match taco with - Some tac-> tac - | None-> default_solver in - let startseq= - match ext with - Void -> (fun gl -> empty_seq !ground_depth) - | Ids l-> create_with_ref_list l !ground_depth - | Bases l-> create_with_auto_hints l !ground_depth in - let result=ground_tac solver startseq gl in - qflag:=backup;result - with e ->qflag:=backup;raise e - -(* special for compatibility with Intuition - -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str - -let defined_connectives=lazy - [[],EvalConstRef (destConst (constant "not")); - [],EvalConstRef (destConst (constant "iff"))] - -let normalize_evaluables= - onAllClauses - (function - None->unfold_in_concl (Lazy.force defined_connectives) - | Some id-> - unfold_in_hyp (Lazy.force defined_connectives) - (Tacexpr.InHypType id)) *) - -TACTIC EXTEND firstorder - [ "firstorder" tactic_opt(t) "using" ne_reference_list(l) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) (Ids l) ] -| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) (Bases l) ] -| [ "firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) Void ] -END - -TACTIC EXTEND gintuition - [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (Option.map eval_tactic t) Void ] -END - - -let default_declarative_automation gls = - tclORELSE - (tclORELSE (Auto.h_trivial [] None) - (Cctac.congruence_tac !congruence_depth [])) - (gen_ground_tac true - (Some (tclTHEN - default_solver - (Cctac.congruence_tac !congruence_depth []))) - Void) gls - - - -let () = - Decl_proof_instr.register_automation_tac default_declarative_automation - diff --git a/contrib/firstorder/ground.ml b/contrib/firstorder/ground.ml deleted file mode 100644 index f4661869..00000000 --- a/contrib/firstorder/ground.ml +++ /dev/null @@ -1,152 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *) - -open Formula -open Sequent -open Rules -open Instances -open Term -open Tacmach -open Tactics -open Tacticals -open Libnames - -(* -let old_search=ref !Auto.searchtable - -(* I use this solution as a means to know whether hints have changed, -but this prevents the GC from collecting the previous table, -resulting in some limited space wasting*) - -let update_flags ()= - if not ( !Auto.searchtable == !old_search ) then - begin - old_search:=!Auto.searchtable; - let predref=ref Names.KNpred.empty in - let f p_a_t = - match p_a_t.Auto.code with - Auto.Unfold_nth (ConstRef kn)-> - predref:=Names.KNpred.add kn !predref - | _ ->() in - let g _ l=List.iter f l in - let h _ hdb=Auto.Hint_db.iter g hdb in - Util.Stringmap.iter h !Auto.searchtable; - red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta (Names.Idpred.full,!predref) - end -*) - -let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn=destConst (Classops.get_coercion_value coe) in - predref:=Names.Cpred.add kn !predref - with Invalid_argument "destConst"-> () in - List.iter f (Classops.coercions ()); - red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta - (Names.Idpred.full,Names.Cpred.complement !predref) - -let ground_tac solver startseq gl= - update_flags (); - let rec toptac skipped seq gl= - if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 - then Pp.msgnl (Printer.pr_goal (sig_it gl)); - tclORELSE (axiom_tac seq.gl seq) - begin - try - let (hd,seq1)=take_formula seq - and re_add s=re_add_formula_list skipped s in - let continue=toptac [] - and backtrack gl=toptac (hd::skipped) seq1 gl in - match hd.pat with - Right rpat-> - begin - match rpat with - Rand-> - and_tac backtrack continue (re_add seq1) - | Rforall-> - let backtrack1= - if !qflag then - tclFAIL 0 (Pp.str "reversible in 1st order mode") - else - backtrack in - forall_tac backtrack1 continue (re_add seq1) - | Rarrow-> - arrow_tac backtrack continue (re_add seq1) - | Ror-> - or_tac backtrack continue (re_add seq1) - | Rfalse->backtrack - | Rexists(i,dom,triv)-> - let (lfp,seq2)=collect_quantified seq in - let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 - continue (re_add seq) - else - backtrack2 (* need special backtracking *) - end - | Left lpat-> - begin - match lpat with - Lfalse-> - left_false_tac hd.id - | Land ind-> - left_and_tac ind backtrack - hd.id continue (re_add seq1) - | Lor ind-> - left_or_tac ind backtrack - hd.id continue (re_add seq1) - | Lforall (_,_,_)-> - let (lfp,seq2)=collect_quantified seq in - let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 - continue (re_add seq) - else - backtrack2 (* need special backtracking *) - | Lexists ind -> - if !qflag then - left_exists_tac ind backtrack hd.id - continue (re_add seq1) - else backtrack - | LA (typ,lap)-> - let la_tac= - begin - match lap with - LLatom -> backtrack - | LLand (ind,largs) | LLor(ind,largs) - | LLfalse (ind,largs)-> - (ll_ind_tac ind largs backtrack - hd.id continue (re_add seq1)) - | LLforall p -> - if seq.depth>0 && !qflag then - (ll_forall_tac p backtrack - hd.id continue (re_add seq1)) - else backtrack - | LLexists (ind,l) -> - if !qflag then - ll_ind_tac ind l backtrack - hd.id continue (re_add seq1) - else - backtrack - | LLarrow (a,b,c) -> - (ll_arrow_tac a b c backtrack - hd.id continue (re_add seq1)) - end in - ll_atom_tac typ la_tac hd.id continue (re_add seq1) - end - with Heap.EmptyHeap->solver - end gl in - wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl - diff --git a/contrib/firstorder/ground.mli b/contrib/firstorder/ground.mli deleted file mode 100644 index 621f99db..00000000 --- a/contrib/firstorder/ground.mli +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ground.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -val ground_tac: Tacmach.tactic -> - (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic - diff --git a/contrib/firstorder/instances.ml b/contrib/firstorder/instances.ml deleted file mode 100644 index 1432207d..00000000 --- a/contrib/firstorder/instances.ml +++ /dev/null @@ -1,206 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*) - -open Formula -open Sequent -open Unify -open Rules -open Util -open Term -open Rawterm -open Tacmach -open Tactics -open Tacticals -open Termops -open Reductionops -open Declarations -open Formula -open Sequent -open Names -open Libnames - -let compare_instance inst1 inst2= - match inst1,inst2 with - Phantom(d1),Phantom(d2)-> - (OrderedConstr.compare d1 d2) - | Real((m1,c1),n1),Real((m2,c2),n2)-> - ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 - | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1 - | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1 - -let compare_gr id1 id2= - if id1==id2 then 0 else - if id1==dummy_id then 1 - else if id2==dummy_id then -1 - else Pervasives.compare id1 id2 - -module OrderedInstance= -struct - type t=instance * Libnames.global_reference - let compare (inst1,id1) (inst2,id2)= - (compare_instance =? compare_gr) inst2 inst1 id2 id1 - (* we want a __decreasing__ total order *) -end - -module IS=Set.Make(OrderedInstance) - -let make_simple_atoms seq= - let ratoms= - match seq.glatom with - Some t->[t] - | None->[] - in {negative=seq.latoms;positive=ratoms} - -let do_sequent setref triv id seq i dom atoms= - let flag=ref true in - let phref=ref triv in - let do_atoms a1 a2 = - let do_pair t1 t2 = - match unif_atoms i dom t1 t2 with - None->() - | Some (Phantom _) ->phref:=true - | Some c ->flag:=false;setref:=IS.add (c,id) !setref in - List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; - List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in - HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; - do_atoms atoms (make_simple_atoms seq); - !flag && !phref - -let match_one_quantified_hyp setref seq lf= - match lf.pat with - Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> - if do_sequent setref triv lf.id seq i dom lf.atoms then - setref:=IS.add ((Phantom dom),lf.id) !setref - | _ ->anomaly "can't happen" - -let give_instances lf seq= - let setref=ref IS.empty in - List.iter (match_one_quantified_hyp setref seq) lf; - IS.elements !setref - -(* collector for the engine *) - -let rec collect_quantified seq= - try - let hd,seq1=take_formula seq in - (match hd.pat with - Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> - let (q,seq2)=collect_quantified seq1 in - ((hd::q),seq2) - | _->[],seq) - with Heap.EmptyHeap -> [],seq - -(* open instances processor *) - -let dummy_constr=mkMeta (-1) - -let dummy_bvid=id_of_string "x" - -let mk_open_instance id gl m t= - let env=pf_env gl in - let evmap=Refiner.project gl in - let var_id= - if id==dummy_id then dummy_bvid else - let typ=pf_type_of gl (constr_of_global id) in - (* since we know we will get a product, - reduction is not too expensive *) - let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in - match nam with - Name id -> id - | Anonymous -> dummy_bvid in - let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in - let rec aux n avoid= - if n=0 then [] else - let nid=(fresh_id avoid var_id gl) in - (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in - let nt=it_mkLambda_or_LetIn revt (aux m []) in - let rawt=Detyping.detype false [] [] nt in - let rec raux n t= - if n=0 then t else - match t with - RLambda(loc,name,k,_,t0)-> - let t1=raux (n-1) t0 in - RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) - | _-> anomaly "can't happen" in - let ntt=try - Pretyping.Default.understand evmap env (raux m rawt) - with _ -> - error "Untypable instance, maybe higher-order non-prenex quantification" in - Sign.decompose_lam_n_assum m ntt - -(* tactics *) - -let left_instance_tac (inst,id) continue seq= - match inst with - Phantom dom-> - if lookup (id,None) seq then - tclFAIL 0 (Pp.str "already done") - else - tclTHENS (cut dom) - [tclTHENLIST - [introf; - (fun gls->generalize - [mkApp(constr_of_global id, - [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); - introf; - tclSOLVE [wrap 1 false continue - (deepen (record (id,None) seq))]]; - tclTRY assumption] - | Real((m,t) as c,_)-> - if lookup (id,Some c) seq then - tclFAIL 0 (Pp.str "already done") - else - let special_generalize= - if m>0 then - fun gl-> - let (rc,ot)= mk_open_instance id gl m t in - let gt= - it_mkLambda_or_LetIn - (mkApp(constr_of_global id,[|ot|])) rc in - generalize [gt] gl - else - generalize [mkApp(constr_of_global id,[|t|])] - in - tclTHENLIST - [special_generalize; - introf; - tclSOLVE - [wrap 1 false continue (deepen (record (id,Some c) seq))]] - -let right_instance_tac inst continue seq= - match inst with - Phantom dom -> - tclTHENS (cut dom) - [tclTHENLIST - [introf; - (fun gls-> - split (Rawterm.ImplicitBindings - [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); - tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY assumption] - | Real ((0,t),_) -> - (tclTHEN (split (Rawterm.ImplicitBindings [t])) - (tclSOLVE [wrap 0 true continue (deepen seq)])) - | Real ((m,t),_) -> - tclFAIL 0 (Pp.str "not implemented ... yet") - -let instance_tac inst= - if (snd inst)==dummy_id then - right_instance_tac (fst inst) - else - left_instance_tac inst - -let quantified_tac lf backtrack continue seq gl= - let insts=give_instances lf seq in - tclORELSE - (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) - backtrack gl - - diff --git a/contrib/firstorder/instances.mli b/contrib/firstorder/instances.mli deleted file mode 100644 index 7667c89f..00000000 --- a/contrib/firstorder/instances.mli +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: instances.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -open Term -open Tacmach -open Names -open Libnames -open Rules - -val collect_quantified : Sequent.t -> Formula.t list * Sequent.t - -val give_instances : Formula.t list -> Sequent.t -> - (Unify.instance * global_reference) list - -val quantified_tac : Formula.t list -> seqtac with_backtracking - - - - diff --git a/contrib/firstorder/rules.ml b/contrib/firstorder/rules.ml deleted file mode 100644 index cc7b19e0..00000000 --- a/contrib/firstorder/rules.ml +++ /dev/null @@ -1,216 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: rules.ml 11512 2008-10-27 12:28:36Z herbelin $ *) - -open Util -open Names -open Term -open Tacmach -open Tactics -open Tacticals -open Termops -open Declarations -open Formula -open Sequent -open Libnames - -type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic - -type lseqtac= global_reference -> seqtac - -type 'a with_backtracking = tactic -> 'a - -let wrap n b continue seq gls= - check_for_interrupt (); - let nc=pf_hyps gls in - let env=pf_env gls in - let rec aux i nc ctx= - if i<=0 then seq else - match nc with - []->anomaly "Not the expected number of hyps" - | ((id,_,typ) as nd)::q-> - if occur_var env id (pf_concl gls) || - List.exists (occur_var_in_decl env id) ctx then - (aux (i-1) q (nd::ctx)) - else - add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in - let seq1=aux n nc [] in - let seq2=if b then - add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in - continue seq2 gls - -let id_of_global=function - VarRef id->id - | _->assert false - -let clear_global=function - VarRef id->clear [id] - | _->tclIDTAC - - -(* connection rules *) - -let axiom_tac t seq= - try exact_no_check (constr_of_global (find_left t seq)) - with Not_found->tclFAIL 0 (Pp.str "No axiom link") - -let ll_atom_tac a backtrack id continue seq= - tclIFTHENELSE - (try - tclTHENLIST - [generalize [mkApp(constr_of_global id, - [|constr_of_global (find_left a seq)|])]; - clear_global id; - intro] - with Not_found->tclFAIL 0 (Pp.str "No link")) - (wrap 1 false continue seq) backtrack - -(* right connectives rules *) - -let and_tac backtrack continue seq= - tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack - -let or_tac backtrack continue seq= - tclORELSE - (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) - backtrack - -let arrow_tac backtrack continue seq= - tclIFTHENELSE intro (wrap 1 true continue seq) - (tclORELSE - (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) - backtrack) -(* left connectives rules *) - -let left_and_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in - tclIFTHENELSE - (tclTHENLIST - [simplest_elim (constr_of_global id); - clear_global id; - tclDO n intro]) - (wrap n false continue seq) - backtrack gls - -let left_or_tac ind backtrack id continue seq gls= - let v=construct_nhyps ind gls in - let f n= - tclTHENLIST - [clear_global id; - tclDO n intro; - wrap n false continue seq] in - tclIFTHENSVELSE - (simplest_elim (constr_of_global id)) - (Array.map f v) - backtrack gls - -let left_false_tac id= - simplest_elim (constr_of_global id) - -(* left arrow connective rules *) - -(* We use this function for false, and, or, exists *) - -let ll_ind_tac ind largs backtrack id continue seq gl= - let rcs=ind_hyps 0 ind largs gl in - let vargs=Array.of_list largs in - (* construire le terme H->B, le generaliser etc *) - let myterm i= - let rc=rcs.(i) in - let p=List.length rc in - let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in - let vars=Array.init p (fun j->mkRel (p-j)) in - let capply=mkApp ((lift p cstr),vars) in - let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in - Sign.it_mkLambda_or_LetIn head rc in - let lp=Array.length rcs in - let newhyps=list_tabulate myterm lp in - tclIFTHENELSE - (tclTHENLIST - [generalize newhyps; - clear_global id; - tclDO lp intro]) - (wrap lp false continue seq) backtrack gl - -let ll_arrow_tac a b c backtrack id continue seq= - let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d=mkLambda (Anonymous,b, - mkApp ((constr_of_global id), - [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in - tclORELSE - (tclTHENS (cut c) - [tclTHENLIST - [introf; - clear_global id; - wrap 1 false continue seq]; - tclTHENS (cut cc) - [exact_no_check (constr_of_global id); - tclTHENLIST - [generalize [d]; - clear_global id; - introf; - introf; - tclCOMPLETE (wrap 2 true continue seq)]]]) - backtrack - -(* quantifier rules (easy side) *) - -let forall_tac backtrack continue seq= - tclORELSE - (tclIFTHENELSE intro (wrap 0 true continue seq) - (tclORELSE - (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) - backtrack)) - (if !qflag then - tclFAIL 0 (Pp.str "reversible in 1st order mode") - else - backtrack) - -let left_exists_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in - tclIFTHENELSE - (simplest_elim (constr_of_global id)) - (tclTHENLIST [clear_global id; - tclDO n intro; - (wrap (n-1) false continue seq)]) - backtrack - gls - -let ll_forall_tac prod backtrack id continue seq= - tclORELSE - (tclTHENS (cut prod) - [tclTHENLIST - [intro; - (fun gls-> - let id0=pf_nth_hyp_id gls 1 in - let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in - tclTHEN (generalize [term]) (clear [id0]) gls); - clear_global id; - intro; - tclCOMPLETE (wrap 1 false continue (deepen seq))]; - tclCOMPLETE (wrap 0 true continue (deepen seq))]) - backtrack - -(* rules for instantiation with unification moved to instances.ml *) - -(* special for compatibility with old Intuition *) - -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str - -let defined_connectives=lazy - [all_occurrences,EvalConstRef (destConst (constant "not")); - all_occurrences,EvalConstRef (destConst (constant "iff"))] - -let normalize_evaluables= - onAllClauses - (function - None->unfold_in_concl (Lazy.force defined_connectives) - | Some ((_,id),_)-> - unfold_in_hyp (Lazy.force defined_connectives) - ((Rawterm.all_occurrences_expr,id),InHypTypeOnly)) diff --git a/contrib/firstorder/rules.mli b/contrib/firstorder/rules.mli deleted file mode 100644 index 3798d8d4..00000000 --- a/contrib/firstorder/rules.mli +++ /dev/null @@ -1,54 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: rules.mli 6141 2004-09-27 14:55:34Z corbinea $ *) - -open Term -open Tacmach -open Names -open Libnames - -type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic - -type lseqtac= global_reference -> seqtac - -type 'a with_backtracking = tactic -> 'a - -val wrap : int -> bool -> seqtac - -val id_of_global: global_reference -> identifier - -val clear_global: global_reference -> tactic - -val axiom_tac : constr -> Sequent.t -> tactic - -val ll_atom_tac : constr -> lseqtac with_backtracking - -val and_tac : seqtac with_backtracking - -val or_tac : seqtac with_backtracking - -val arrow_tac : seqtac with_backtracking - -val left_and_tac : inductive -> lseqtac with_backtracking - -val left_or_tac : inductive -> lseqtac with_backtracking - -val left_false_tac : global_reference -> tactic - -val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking - -val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking - -val forall_tac : seqtac with_backtracking - -val left_exists_tac : inductive -> lseqtac with_backtracking - -val ll_forall_tac : types -> lseqtac with_backtracking - -val normalize_evaluables : tactic diff --git a/contrib/firstorder/sequent.ml b/contrib/firstorder/sequent.ml deleted file mode 100644 index e931f8fd..00000000 --- a/contrib/firstorder/sequent.ml +++ /dev/null @@ -1,303 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: sequent.ml 11282 2008-07-28 11:51:53Z msozeau $ *) - -open Term -open Util -open Formula -open Unify -open Tacmach -open Names -open Libnames -open Pp - -let newcnt ()= - let cnt=ref (-1) in - fun b->if b then incr cnt;!cnt - -let priority = (* pure heuristics, <=0 for non reversible *) - function - Right rf-> - begin - match rf with - Rarrow -> 100 - | Rand -> 40 - | Ror -> -15 - | Rfalse -> -50 - | Rforall -> 100 - | Rexists (_,_,_) -> -29 - end - | Left lf -> - match lf with - Lfalse -> 999 - | Land _ -> 90 - | Lor _ -> 40 - | Lforall (_,_,_) -> -30 - | Lexists _ -> 60 - | LA(_,lap) -> - match lap with - LLatom -> 0 - | LLfalse (_,_) -> 100 - | LLand (_,_) -> 80 - | LLor (_,_) -> 70 - | LLforall _ -> -20 - | LLexists (_,_) -> 50 - | LLarrow (_,_,_) -> -10 - -let left_reversible lpat=(priority lpat)>0 - -module OrderedFormula= -struct - type t=Formula.t - let compare e1 e2= - (priority e1.pat) - (priority e2.pat) -end - -(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed; Cast's, - application associativity, binders name and Cases annotations are - not taken into account *) - -let rec compare_list f l1 l2= - match l1,l2 with - [],[]-> 0 - | [],_ -> -1 - | _,[] -> 1 - | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 - -let compare_array f v1 v2= - let l=Array.length v1 in - let c=l - Array.length v2 in - if c=0 then - let rec comp_aux i= - if i<0 then 0 - else - let ci=f v1.(i) v2.(i) in - if ci=0 then - comp_aux (i-1) - else ci - in comp_aux (l-1) - else c - -let compare_constr_int f t1 t2 = - match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> n1 - n2 - | Meta m1, Meta m2 -> m1 - m2 - | Var id1, Var id2 -> Pervasives.compare id1 id2 - | Sort s1, Sort s2 -> Pervasives.compare s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> - (f =? f) t1 t2 c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> - ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 - | App (_,_), App (_,_) -> - let c1,l1=decompose_app t1 - and c2,l2=decompose_app t2 in - (f =? (compare_list f)) c1 c2 l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> - ((-) =? (compare_array f)) e1 e2 l1 l2 - | Const c1, Const c2 -> Pervasives.compare c1 c2 - | Ind c1, Ind c2 -> Pervasives.compare c1 c2 - | Construct c1, Construct c2 -> Pervasives.compare c1 c2 - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2 - | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> - ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) - ln1 ln2 tl1 tl2 bl1 bl2 - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) - ln1 ln2 tl1 tl2 bl1 bl2 - | _ -> Pervasives.compare t1 t2 - -let rec compare_constr m n= - compare_constr_int compare_constr m n - -module OrderedConstr= -struct - type t=constr - let compare=compare_constr -end - -type h_item = global_reference * (int*constr) option - -module Hitem= -struct - type t = h_item - let compare (id1,co1) (id2,co2)= - (Pervasives.compare - =? (fun oc1 oc2 -> - match oc1,oc2 with - Some (m1,c1),Some (m2,c2) -> - ((-) =? OrderedConstr.compare) m1 m2 c1 c2 - | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 -end - -module CM=Map.Make(OrderedConstr) - -module History=Set.Make(Hitem) - -let cm_add typ nam cm= - try - let l=CM.find typ cm in CM.add typ (nam::l) cm - with - Not_found->CM.add typ [nam] cm - -let cm_remove typ nam cm= - try - let l=CM.find typ cm in - let l0=List.filter (fun id->id<>nam) l in - match l0 with - []->CM.remove typ cm - | _ ->CM.add typ l0 cm - with Not_found ->cm - -module HP=Heap.Functional(OrderedFormula) - -type t= - {redexes:HP.t; - context:(global_reference list) CM.t; - latoms:constr list; - gl:types; - glatom:constr option; - cnt:counter; - history:History.t; - depth:int} - -let deepen seq={seq with depth=seq.depth-1} - -let record item seq={seq with history=History.add item seq.history} - -let lookup item seq= - History.mem item seq.history || - match item with - (_,None)->false - | (id,Some ((m,t) as c))-> - let p (id2,o)= - match o with - None -> false - | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in - History.exists p seq.history - -let rec add_formula side nam t seq gl= - match build_formula side nam t gl seq.cnt with - Left f-> - begin - match side with - Concl -> - {seq with - redexes=HP.add f seq.redexes; - gl=f.constr; - glatom=None} - | _ -> - {seq with - redexes=HP.add f seq.redexes; - context=cm_add f.constr nam seq.context} - end - | Right t-> - match side with - Concl -> - {seq with gl=t;glatom=Some t} - | _ -> - {seq with - context=cm_add t nam seq.context; - latoms=t::seq.latoms} - -let re_add_formula_list lf seq= - let do_one f cm= - if f.id == dummy_id then cm - else cm_add f.constr f.id cm in - {seq with - redexes=List.fold_right HP.add lf seq.redexes; - context=List.fold_right do_one lf seq.context} - -let find_left t seq=List.hd (CM.find t seq.context) - -(*let rev_left seq= - try - let lpat=(HP.maximum seq.redexes).pat in - left_reversible lpat - with Heap.EmptyHeap -> false -*) -let no_formula seq= - seq.redexes=HP.empty - -let rec take_formula seq= - let hd=HP.maximum seq.redexes - and hp=HP.remove seq.redexes in - if hd.id == dummy_id then - let nseq={seq with redexes=hp} in - if seq.gl==hd.constr then - hd,nseq - else - take_formula nseq (* discarding deprecated goal *) - else - hd,{seq with - redexes=hp; - context=cm_remove hd.constr hd.id seq.context} - -let empty_seq depth= - {redexes=HP.empty; - context=CM.empty; - latoms=[]; - gl=(mkMeta 1); - glatom=None; - cnt=newcnt (); - history=History.empty; - depth=depth} - -let create_with_ref_list l depth gl= - let f gr seq= - let c=constr_of_global gr in - let typ=(pf_type_of gl c) in - add_formula Hyp gr typ seq gl in - List.fold_right f l (empty_seq depth) - -open Auto - -let create_with_auto_hints l depth gl= - let seqref=ref (empty_seq depth) in - let f p_a_t = - match p_a_t.code with - Res_pf (c,_) | Give_exact c - | Res_pf_THEN_trivial_fail (c,_) -> - (try - let gr=global_of_constr c in - let typ=(pf_type_of gl c) in - seqref:=add_formula Hint gr typ !seqref gl - with Not_found->()) - | _-> () in - let g _ l=List.iter f l in - let h dbname= - let hdb= - try - searchtable_map dbname - with Not_found-> - error ("Firstorder: "^dbname^" : No such Hint database") in - Hint_db.iter g hdb in - List.iter h l; - !seqref - -let print_cmap map= - let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) c in - str "| " ++ - Util.prlist Printer.pr_global l ++ - str " : " ++ - Ppconstr.pr_constr_expr xc ++ - cut () ++ - s in - msgnl (v 0 - (str "-----" ++ - cut () ++ - CM.fold print_entry map (mt ()) ++ - str "-----")) - - diff --git a/contrib/firstorder/sequent.mli b/contrib/firstorder/sequent.mli deleted file mode 100644 index 47fb74c7..00000000 --- a/contrib/firstorder/sequent.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: sequent.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term -open Util -open Formula -open Tacmach -open Names -open Libnames - -module OrderedConstr: Set.OrderedType with type t=constr - -module CM: Map.S with type key=constr - -type h_item = global_reference * (int*constr) option - -module History: Set.S with type elt = h_item - -val cm_add : constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t - -val cm_remove : constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t - -module HP: Heap.S with type elt=Formula.t - -type t = {redexes:HP.t; - context: global_reference list CM.t; - latoms:constr list; - gl:types; - glatom:constr option; - cnt:counter; - history:History.t; - depth:int} - -val deepen: t -> t - -val record: h_item -> t -> t - -val lookup: h_item -> t -> bool - -val add_formula : side -> global_reference -> constr -> t -> - Proof_type.goal sigma -> t - -val re_add_formula_list : Formula.t list -> t -> t - -val find_left : constr -> t -> global_reference - -val take_formula : t -> Formula.t * t - -val empty_seq : int -> t - -val create_with_ref_list : global_reference list -> - int -> Proof_type.goal sigma -> t - -val create_with_auto_hints : Auto.hint_db_name list -> - int -> Proof_type.goal sigma -> t - -val print_cmap: global_reference list CM.t -> unit diff --git a/contrib/firstorder/unify.ml b/contrib/firstorder/unify.ml deleted file mode 100644 index 27c06f54..00000000 --- a/contrib/firstorder/unify.ml +++ /dev/null @@ -1,143 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: unify.ml 11897 2009-02-09 19:28:02Z barras $ i*) - -open Util -open Formula -open Tacmach -open Term -open Names -open Termops -open Reductionops - -exception UFAIL of constr*constr - -(* - RIGID-only Martelli-Montanari style unification for CLOSED terms - I repeat : t1 and t2 must NOT have ANY free deBruijn - sigma is kept normal with respect to itself but is lazily applied - to the equation set. Raises UFAIL with a pair of terms -*) - -let unif t1 t2= - let bige=Queue.create () - and sigma=ref [] in - let bind i t= - sigma:=(i,t):: - (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in - let rec head_reduce t= - (* forbids non-sigma-normal meta in head position*) - match kind_of_term t with - Meta i-> - (try - head_reduce (List.assoc i !sigma) - with Not_found->t) - | _->t in - Queue.add (t1,t2) bige; - try while true do - let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) - and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in - match (kind_of_term nt1),(kind_of_term nt2) with - Meta i,Meta j-> - if i<>j then - if i<j then bind j nt1 - else bind i nt2 - | Meta i,_ -> - let t=subst_meta !sigma nt2 in - if Intset.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then - bind i t else raise (UFAIL(nt1,nt2)) - | _,Meta i -> - let t=subst_meta !sigma nt1 in - if Intset.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then - bind i t else raise (UFAIL(nt1,nt2)) - | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige - | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige - | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> - Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in - if l<>(Array.length vb) then - raise (UFAIL (nt1,nt2)) - else - for i=0 to l-1 do - Queue.add (va.(i),vb.(i)) bige - done - | App(ha,va),App(hb,vb)-> - Queue.add (ha,hb) bige; - let l=Array.length va in - if l<>(Array.length vb) then - raise (UFAIL (nt1,nt2)) - else - for i=0 to l-1 do - Queue.add (va.(i),vb.(i)) bige - done - | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) - done; - assert false - (* this place is unreachable but needed for the sake of typing *) - with Queue.Empty-> !sigma - -let value i t= - let add x y= - if x<0 then y else if y<0 then x else x+y in - let tref=mkMeta i in - let rec vaux term= - if term=tref then 0 else - let f v t=add v (vaux t) in - let vr=fold_constr f (-1) term in - if vr<0 then -1 else vr+1 in - vaux t - -type instance= - Real of (int*constr)*int - | Phantom of constr - -let mk_rel_inst t= - let new_rel=ref 1 in - let rel_env=ref [] in - let rec renum_rec d t= - match kind_of_term t with - Meta n-> - (try - mkRel (d+(List.assoc n !rel_env)) - with Not_found-> - let m= !new_rel in - incr new_rel; - rel_env:=(n,m) :: !rel_env; - mkRel (m+d)) - | _ -> map_constr_with_binders succ renum_rec d t - in - let nt=renum_rec 0 t in (!new_rel - 1,nt) - -let unif_atoms i dom t1 t2= - try - let t=List.assoc i (unif t1 t2) in - if isMeta t then Some (Phantom dom) - else Some (Real(mk_rel_inst t,value i t1)) - with - UFAIL(_,_) ->None - | Not_found ->Some (Phantom dom) - -let renum_metas_from k n t= (* requires n = max (free_rels t) *) - let l=list_tabulate (fun i->mkMeta (k+i)) n in - substl l t - -let more_general (m1,t1) (m2,t2)= - let mt1=renum_metas_from 0 m1 t1 - and mt2=renum_metas_from m1 m2 t2 in - try - let sigma=unif mt1 mt2 in - let p (n,t)= n<m1 || isMeta t in - List.for_all p sigma - with UFAIL(_,_)->false diff --git a/contrib/firstorder/unify.mli b/contrib/firstorder/unify.mli deleted file mode 100644 index 9fbe3dda..00000000 --- a/contrib/firstorder/unify.mli +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: unify.mli 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Term - -exception UFAIL of constr*constr - -val unif : constr -> constr -> (int*constr) list - -type instance= - Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) - | Phantom of constr (* domaine de quantification *) - -val unif_atoms : metavariable -> constr -> constr -> constr -> instance option - -val more_general : (int*constr) -> (int*constr) -> bool diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v deleted file mode 100644 index 024aa1c3..00000000 --- a/contrib/fourier/Fourier.v +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Fourier.v 11672 2008-12-12 14:45:09Z herbelin $ *) - -(* "Fourier's method to solve linear inequations/equations systems.".*) - -Require Export Fourier_util. -Require Export LegacyField. -Require Export DiscrR. - -Ltac fourier := abstract (fourierz; field; discrR). - -Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v deleted file mode 100644 index 6a9ab051..00000000 --- a/contrib/fourier/Fourier_util.v +++ /dev/null @@ -1,222 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *) - -Require Export Rbase. -Comments "Lemmas used by the tactic Fourier". - -Open Scope R_scope. - -Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1. -intros; apply Rmult_lt_compat_l; assumption. -Qed. - -Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. -red in |- *. -intros. -case H; auto with real. -Qed. - -Lemma Rfourier_lt_lt : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt. -try exact H0. -try exact H1. -Qed. - -Lemma Rfourier_lt_le : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt; auto with real. -rewrite H2. -rewrite (Rplus_comm y1 (a * y2)). -rewrite (Rplus_comm x1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H. -Qed. - -Lemma Rfourier_le_lt : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H; intros. -apply Rfourier_lt_le; auto with real. -rewrite H2. -apply Rplus_lt_compat_l. -apply Rfourier_lt; auto with real. -Qed. - -Lemma Rfourier_le_le : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -red in |- *. -left; try assumption. -apply Rfourier_le_lt; auto with real. -rewrite H2. -case H; intros. -red in |- *. -left; try assumption. -rewrite (Rplus_comm x1 (a * y2)). -rewrite (Rplus_comm y1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H3. -rewrite H3. -red in |- *. -right; try assumption. -auto with real. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rle_lt_0_plus_1. -red in |- *; auto with real. -Qed. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -apply Rmult_lt_compat_l; auto with real. -ring. -Qed. - -Lemma Rlt_zero_1 : 0 < 1. -exact Rlt_0_1. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. -intros x H; try assumption. -case H; intros. -red in |- *. -left; try assumption. -apply Rlt_zero_pos_plus1; auto with real. -rewrite <- H0. -replace (1 + 0) with 1. -red in |- *; left. -exact Rlt_zero_1. -ring. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -red in |- *; left. -apply Rlt_mult_inv_pos; auto with real. -rewrite <- H1. -red in |- *; right; ring. -Qed. - -Lemma Rle_zero_1 : 0 <= 1. -red in |- *; left. -exact Rlt_zero_1. -Qed. - -Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. -intros n d H; red in |- *; intros H0; try exact H0. -generalize (Rgt_not_le 0 (n * / d)). -intros H1; elim H1; try assumption. -replace (n * / d) with (- - (n * / d)). -replace 0 with (- -0). -replace (- (n * / d)) with (- n * / d). -replace (-0) with 0. -red in |- *. -apply Ropp_gt_lt_contravar. -red in |- *. -exact H0. -ring. -ring. -ring. -ring. -Qed. - -Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. -intros x; try assumption. -replace (0 * x) with 0. -apply Rlt_irrefl. -ring. -Qed. - -Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. -intros n d H; try assumption. -apply Rgt_not_le. -replace 0 with (-0). -replace (- n * / d) with (- (n * / d)). -apply Ropp_lt_gt_contravar. -try exact H. -ring. -ring. -Qed. - -Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. -unfold not in |- *; intros. -apply H. -apply Rplus_lt_reg_r with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H0. -ring. -ring. -Qed. - -Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. -unfold not in |- *; intros. -apply H. -case H0; intros. -left. -apply Rplus_lt_reg_r with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H1. -ring. -ring. -right. -rewrite H1; ring. -Qed. - -Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. -unfold Rgt in |- *; intros; assumption. -Qed. - -Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. -intros x y; exact (Rge_le y x). -Qed. - -Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. -exact Req_le. -Qed. - -Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. -exact Req_le_sym. -Qed. - -Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. -exact Rnot_ge_lt. -Qed. - -Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. -exact Rnot_gt_le. -Qed. - -Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. -exact Rnot_le_lt. -Qed. - -Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. -exact Rnot_lt_ge. -Qed. diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml deleted file mode 100644 index 195d8605..00000000 --- a/contrib/fourier/fourier.ml +++ /dev/null @@ -1,205 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: fourier.ml 11671 2008-12-12 12:43:03Z herbelin $ *) - -(* Méthode d'élimination de Fourier *) -(* Référence: -Auteur(s) : Fourier, Jean-Baptiste-Joseph - -Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... - -Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 - -Pages: 326-327 - -http://gallica.bnf.fr/ -*) - -(* Un peu de calcul sur les rationnels... -Les opérations rendent des rationnels normalisés, -i.e. le numérateur et le dénominateur sont premiers entre eux. -*) -type rational = {num:int; - den:int} -;; -let print_rational x = - print_int x.num; - print_string "/"; - print_int x.den -;; - -let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);; - - -let r0 = {num=0;den=1};; -let r1 = {num=1;den=1};; - -let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in - if x.num=0 then r0 - else (let d=pgcd x.num x.den in - let d= (if d<0 then -d else d) in - {num=(x.num)/d;den=(x.den)/d});; - -let rop x = rnorm {num=(-x.num);den=x.den};; - -let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; - -let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};; - -let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};; - -let rinv x = rnorm {num=x.den;den=x.num};; - -let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};; - -let rinf x y = x.num*y.den < y.num*x.den;; -let rinfeq x y = x.num*y.den <= y.num*x.den;; - -(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation -c1x1+...+cnxn < d si strict=true, <= sinon, -hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ. -*) - -type ineq = {coef:rational list; - hist:rational list; - strict:bool};; - -let pop x l = l:=x::(!l);; - -(* sépare la liste d'inéquations s selon que leur premier coefficient est -négatif, nul ou positif. *) -let partitionne s = - let lpos=ref [] in - let lneg=ref [] in - let lnul=ref [] in - List.iter (fun ie -> match ie.coef with - [] -> raise (Failure "empty ineq") - |(c::r) -> if rinf c r0 - then pop ie lneg - else if rinf r0 c then pop ie lpos - else pop ie lnul) - s; - [!lneg;!lnul;!lpos] -;; -(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): -(add_hist [(equation 1, s1);...;(équation n, sn)]) -= -[{équation 1, [1;0;...;0], s1}; - {équation 2, [0;1;...;0], s2}; - ... - {équation n, [0;0;...;1], sn}] -*) -let add_hist le = - let n = List.length le in - let i=ref 0 in - List.map (fun (ie,s) -> - let h =ref [] in - for k=1 to (n-(!i)-1) do pop r0 h; done; - pop r1 h; - for k=1 to !i do pop r0 h; done; - i:=!i+1; - {coef=ie;hist=(!h);strict=s}) - le -;; -(* additionne deux inéquations *) -let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; - hist=List.map2 rplus ie1.hist ie2.hist; - strict=ie1.strict || ie2.strict} -;; -(* multiplication d'une inéquation par un rationnel (positif) *) -let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; - hist=List.map (fun x -> rmult a x) ie.hist; - strict= ie.strict} -;; -(* on enlève le premier coefficient *) -let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} -;; -(* le premier coefficient: "tête" de l'inéquation *) -let hd_coef ie = List.hd ie.coef -;; - -(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. -*) -let deduce_add lneg lpos = - let res=ref [] in - List.iter (fun i1 -> - List.iter (fun i2 -> - let a = rop (hd_coef i1) in - let b = hd_coef i2 in - pop (ie_tl (ie_add (ie_emult b i1) - (ie_emult a i2))) res) - lpos) - lneg; - !res -;; -(* élimination de la première variable à partir d'une liste d'inéquations: -opération qu'on itère dans l'algorithme de Fourier. -*) -let deduce1 s = - match (partitionne s) with - [lneg;lnul;lpos] -> - let lnew = deduce_add lneg lpos in - (List.map ie_tl lnul)@lnew - |_->assert false -;; -(* algorithme de Fourier: on élimine successivement toutes les variables. -*) -let deduce lie = - let n = List.length (fst (List.hd lie)) in - let lie=ref (add_hist lie) in - for i=1 to n-1 do - lie:= deduce1 !lie; - done; - !lie -;; - -(* donne [] si le système a des solutions, -sinon donne [c,s,lc] -où lc est la combinaison linéaire des inéquations de départ -qui donne 0 < c si s=true - ou 0 <= c sinon -cette inéquation étant absurde. -*) -let unsolvable lie = - let lr = deduce lie in - let res = ref [] in - (try (List.iter (fun e -> - match e with - {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) - then (res := [c,s,lc]; - raise (Failure "contradiction found")) - |_->assert false) - lr) - with _ -> ()); - !res -;; - -(* Exemples: - -let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; -deduce test1;; -unsolvable test1;; - -let test2=[ -[r1;r1;r0;r0;r0],false; -[r0;r1;r1;r0;r0],false; -[r0;r0;r1;r1;r0],false; -[r0;r0;r0;r1;r1],false; -[r1;r0;r0;r0;r1],false; -[rop r1;rop r1;r0;r0;r0],false; -[r0;rop r1;rop r1;r0;r0],false; -[r0;r0;rop r1;rop r1;r0],false; -[r0;r0;r0;rop r1;rop r1],false; -[rop r1;r0;r0;r0;rop r1],false -];; -deduce test2;; -unsolvable test2;; - -*) diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml deleted file mode 100644 index 114d5f9c..00000000 --- a/contrib/fourier/fourierR.ml +++ /dev/null @@ -1,629 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *) - - - -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients -des inéquations et équations sont entiers. En attendant la tactique Field. -*) - -open Term -open Tactics -open Clenv -open Names -open Libnames -open Tacticals -open Tacmach -open Fourier -open Contradiction - -(****************************************************************************** -Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. -*) - -type flin = {fhom:(constr , rational)Hashtbl.t; - fcste:rational};; - -let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};; - -let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;; - -let flin_add f x c = - let cx = flin_coef f x in - Hashtbl.remove f.fhom x; - Hashtbl.add f.fhom x (rplus cx c); - f -;; -let flin_add_cste f c = - {fhom=f.fhom; - fcste=rplus f.fcste c} -;; - -let flin_one () = flin_add_cste (flin_zero()) r1;; - -let flin_plus f1 f2 = - let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; -;; - -let flin_minus f1 f2 = - let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); -;; -let flin_emult a f = - let f2 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; - flin_add_cste f2 (rmult a f.fcste); -;; - -(*****************************************************************************) -open Vernacexpr - -type ineq = Rlt | Rle | Rgt | Rge - -let string_of_R_constant kn = - match Names.repr_con kn with - | MPfile dir, sec_dir, id when - sec_dir = empty_dirpath && - string_of_dirpath dir = "Coq.Reals.Rdefinitions" - -> string_of_label id - | _ -> "constant_not_of_R" - -let rec string_of_R_constr c = - match kind_of_term c with - Cast (c,_,_) -> string_of_R_constr c - |Const c -> string_of_R_constant c - | _ -> "not_of_constant" - -let rec rational_of_constr c = - match kind_of_term c with - | Cast (c,_,_) -> (rational_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - | "Ropp" -> - rop (rational_of_constr args.(0)) - | "Rinv" -> - rinv (rational_of_constr args.(0)) - | "Rmult" -> - rmult (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rdiv" -> - rdiv (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rplus" -> - rplus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rminus" -> - rminus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | _ -> failwith "not a rational") - | Const kn -> - (match (string_of_R_constant kn) with - "R1" -> r1 - |"R0" -> r0 - | _ -> failwith "not a rational") - | _ -> failwith "not a rational" -;; - -let rec flin_of_constr c = - try( - match kind_of_term c with - | Cast (c,_,_) -> (flin_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - "Ropp" -> - flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> - flin_plus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rminus"-> - flin_minus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rmult"-> - (try (let a=(rational_of_constr args.(0)) in - try (let b = (rational_of_constr args.(1)) in - (flin_add_cste (flin_zero()) (rmult a b))) - with _-> (flin_add (flin_zero()) - args.(1) - a)) - with _-> (flin_add (flin_zero()) - args.(0) - (rational_of_constr args.(1)))) - | "Rinv"-> - let a=(rational_of_constr args.(0)) in - flin_add_cste (flin_zero()) (rinv a) - | "Rdiv"-> - (let b=(rational_of_constr args.(1)) in - try (let a = (rational_of_constr args.(0)) in - (flin_add_cste (flin_zero()) (rdiv a b))) - with _-> (flin_add (flin_zero()) - args.(0) - (rinv b))) - |_->assert false) - | Const c -> - (match (string_of_R_constant c) with - "R1" -> flin_one () - |"R0" -> flin_zero () - |_-> assert false) - |_-> assert false) - with _ -> flin_add (flin_zero()) - c - r1 -;; - -let flin_to_alist f = - let res=ref [] in - Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f; - !res -;; - -(* Représentation des hypothèses qui sont des inéquations ou des équations. -*) -type hineq={hname:constr; (* le nom de l'hypothèse *) - htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) - hleft:constr; - hright:constr; - hflin:flin; - hstrict:bool} -;; - -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 -*) -let ineq1_of_constr (h,t) = - match (kind_of_term t) with - App (f,args) -> - (match kind_of_term f with - Const c when Array.length args = 2 -> - let t1= args.(0) in - let t2= args.(1) in - (match (string_of_R_constant c) with - "Rlt" -> [{hname=h; - htype="Rlt"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=true}] - |"Rgt" -> [{hname=h; - htype="Rgt"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=true}] - |"Rle" -> [{hname=h; - htype="Rle"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}] - |"Rge" -> [{hname=h; - htype="Rge"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_->assert false) - | Ind (kn,i) -> - if IndRef(kn,i) = Coqlib.glob_eq then - let t0= args.(0) in - let t1= args.(1) in - let t2= args.(2) in - (match (kind_of_term t0) with - Const c -> - (match (string_of_R_constant c) with - "R"-> - [{hname=h; - htype="eqTLR"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}; - {hname=h; - htype="eqTRL"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> assert false) - |_-> assert false) - else - assert false - |_-> assert false) - |_-> assert false -;; - -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) -*) - -let fourier_lineq lineq1 = - let nvar=ref (-1) in - let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) - List.iter (fun f -> - Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin - nvar:=(!nvar)+1; - Hashtbl.add hvar x (!nvar) - end) - f.hflin.fhom) - lineq1; - let sys= List.map (fun h-> - let v=Array.create ((!nvar)+1) r0 in - Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) - h.hflin.fhom; - ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) - lineq1 in - unsolvable sys -;; - -(*********************************************************************) -(* Defined constants *) - -let get = Lazy.force -let constant = Coqlib.gen_constant "Fourier" - -(* Standard library *) -open Coqlib -let coq_sym_eqT = lazy (build_coq_sym_eq ()) -let coq_False = lazy (build_coq_False ()) -let coq_not = lazy (build_coq_not ()) -let coq_eq = lazy (build_coq_eq ()) - -(* Rdefinitions *) -let constant_real = constant ["Reals";"Rdefinitions"] - -let coq_Rlt = lazy (constant_real "Rlt") -let coq_Rgt = lazy (constant_real "Rgt") -let coq_Rle = lazy (constant_real "Rle") -let coq_Rge = lazy (constant_real "Rge") -let coq_R = lazy (constant_real "R") -let coq_Rminus = lazy (constant_real "Rminus") -let coq_Rmult = lazy (constant_real "Rmult") -let coq_Rplus = lazy (constant_real "Rplus") -let coq_Ropp = lazy (constant_real "Ropp") -let coq_Rinv = lazy (constant_real "Rinv") -let coq_R0 = lazy (constant_real "R0") -let coq_R1 = lazy (constant_real "R1") - -(* RIneq *) -let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") - -(* Fourier_util *) -let constant_fourier = constant ["fourier";"Fourier_util"] - -let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") -let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") -let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") -let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") -let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") -let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") -let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") -let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") -let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") -let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") -let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") -let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") -let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") - -let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") -let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") -let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") -let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") -let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") -let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") -let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") -let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") -let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") -let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") -let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") -let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") -let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") - -(****************************************************************************** -Construction de la preuve en cas de succès de la méthode de Fourier, -i.e. on obtient une contradiction. -*) -let is_int x = (x.den)=1 -;; - -(* fraction = couple (num,den) *) -let rec rational_to_fraction x= (x.num,x.den) -;; - -(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) -*) -let int_to_real n = - let nn=abs n in - if nn=0 - then get coq_R0 - else - (let s=ref (get coq_R1) in - for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; - if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) -;; -(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) -*) -let rational_to_real x = - let (n,d)=rational_to_fraction x in - mkApp (get coq_Rmult, - [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) -;; - -(* preuve que 0<n*1/d -*) -let tac_zero_inf_pos gl (n,d) = - let tacn=ref (apply (get coq_Rlt_zero_1)) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do - tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; - for i=1 to d-1 do - tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<=n*1/d -*) -let tac_zero_infeq_pos gl (n,d)= - let tacn=ref (if n=0 - then (apply (get coq_Rle_zero_zero)) - else (apply (get coq_Rle_zero_1))) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do - tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; - for i=1 to d-1 do - tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<(-n)*(1/d) => False -*) -let tac_zero_inf_false gl (n,d) = - if n=0 then (apply (get coq_Rnot_lt0)) - else - (tclTHEN (apply (get coq_Rle_not_lt)) - (tac_zero_infeq_pos gl (-n,d))) -;; - -(* preuve que 0<=(-n)*(1/d) => False -*) -let tac_zero_infeq_false gl (n,d) = - (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) - (tac_zero_inf_pos gl (-n,d))) -;; - -let create_meta () = mkMeta(Evarutil.new_meta());; - -let my_cut c gl= - let concl = pf_concl gl in - apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl -;; - -let exact = exact_check;; - -let tac_use h = match h.htype with - "Rlt" -> exact h.hname - |"Rle" -> exact h.hname - |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt)) - (exact h.hname)) - |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le)) - (exact h.hname)) - |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) - (exact h.hname)) - |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) - (exact h.hname)) - |_->assert false -;; - -(* -let is_ineq (h,t) = - match (kind_of_term t) with - App (f,args) -> - (match (string_of_R_constr f) with - "Rlt" -> true - | "Rgt" -> true - | "Rle" -> true - | "Rge" -> true -(* Wrong:not in Rdefinitions: *) | "eqT" -> - (match (string_of_R_constr args.(0)) with - "R" -> true - | _ -> false) - | _ ->false) - |_->false -;; -*) - -let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; - -let mkAppL a = - let l = Array.to_list a in - mkApp(List.hd l, Array.of_list (List.tl l)) -;; - -(* Résolution d'inéquations linéaires dans R *) -let rec fourier gl= - Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = strip_outer_cast (pf_concl gl) in - let fhyp=id_of_string "new_hyp_for_fourier" in - (* si le but est une inéquation, on introduit son contraire, - et le but à prouver devient False *) - try (let tac = - match (kind_of_term goal) with - App (f,args) -> - (match (string_of_R_constr f) with - "Rlt" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) - (intro_using fhyp)) - fourier) - |"Rle" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_gt_le)) - (intro_using fhyp)) - fourier) - |"Rgt" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_le_gt)) - (intro_using fhyp)) - fourier) - |"Rge" -> - (tclTHEN - (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) - (intro_using fhyp)) - fourier) - |_->assert false) - |_->assert false - in tac gl) - with _ -> - (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (mkVar h,t)) - (list_of_sign (pf_hyps gl)) in - let lineq =ref [] in - List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with _ -> ()) - hyps; - (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then Util.error "No inequalities"; - let res=fourier_lineq (!lineq) in - let tac=ref tclIDTAC in - if res=[] - then Util.error "fourier failed" - (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) - else (match res with - [(cres,sres,lc)]-> - (* lc=coefficients multiplicateurs des inéquations - qui donnent 0<cres ou 0<=cres selon sres *) - (*print_string "Fourier's method can prove the goal...";flush stdout;*) - let lutil=ref [] in - List.iter - (fun (h,c) -> - if c<>r0 - then (lutil:=(h,c)::(!lutil)(*; - print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); - (* on construit la combinaison linéaire des inéquation *) - (match (!lutil) with - (h1,c1)::lutil -> - let s=ref (h1.hstrict) in - let t1=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hleft|]) in - let t2=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hright|]) in - List.iter (fun (h,c) -> - s:=(!s)||(h.hstrict); - t1:=(mkAppL [|get coq_Rplus; - !t1; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hleft|] |]); - t2:=(mkAppL [|get coq_Rplus; - !t2; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hright|] |])) - lutil; - let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; - !t1; - !t2 |] in - let tc=rational_to_real cres in - (* puis sa preuve *) - let tac1=ref (if h1.hstrict - then (tclTHENS (apply (get coq_Rfourier_lt)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)]) - else (tclTHENS (apply (get coq_Rfourier_le)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)])) in - s:=h1.hstrict; - List.iter (fun (h,c)-> - (if (!s) - then (if h.hstrict - then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)])) - else (if h.hstrict - then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]))); - s:=(!s)||(h.hstrict)) - lutil; - let tac2= if sres - then tac_zero_inf_false gl (rational_to_fraction cres) - else tac_zero_infeq_false gl (rational_to_fraction cres) - in - tac:=(tclTHENS (my_cut ineq) - [tclTHEN (change_in_concl None - (mkAppL [| get coq_not; ineq|] - )) - (tclTHEN (apply (if sres then get coq_Rnot_lt_lt - else get coq_Rnot_le_le)) - (tclTHENS (Equality.replace - (mkAppL [|get coq_Rminus;!t2;!t1|] - ) - tc) - [tac2; - (tclTHENS - (Equality.replace - (mkApp (get coq_Rinv, - [|get coq_R1|])) - (get coq_R1)) -(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) - - [tclORELSE - (Ring.polynom []) - tclIDTAC; - (tclTHEN (apply (get coq_sym_eqT)) - (apply (get coq_Rinv_1)))] - - ) - ])); - !tac1]); - tac:=(tclTHENS (cut (get coq_False)) - [tclTHEN intro (contradiction None); - !tac]) - |_-> assert false) |_-> assert false - ); -(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - (!tac gl) -(* ((tclABSTRACT None !tac) gl) *) - -;; - -(* -let fourier_tac x gl = - fourier gl -;; - -let v_fourier = add_tactic "Fourier" fourier_tac -*) - diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4 deleted file mode 100644 index 3a6be850..00000000 --- a/contrib/fourier/g_fourier.ml4 +++ /dev/null @@ -1,17 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_fourier.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) - -open FourierR - -TACTIC EXTEND fourier - [ "fourierz" ] -> [ fourier ] -END diff --git a/contrib/funind/Recdef.v b/contrib/funind/Recdef.v deleted file mode 100644 index 2d206220..00000000 --- a/contrib/funind/Recdef.v +++ /dev/null @@ -1,48 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -Require Compare_dec. -Require Wf_nat. - -Section Iter. -Variable A : Type. - -Fixpoint iter (n : nat) : (A -> A) -> A -> A := - fun (fl : A -> A) (def : A) => - match n with - | O => def - | S m => fl (iter m fl def) - end. -End Iter. - -Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). - intro p; intro p'; change (S p <= S (S (p + p'))); - apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); - apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. -Qed. - - -Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). - intro p; intro p'; change (S p' <= S (p + p')); - apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; - apply Plus.le_plus_r. -Qed. - -Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). -intro x; intro y; intro H; change (S x <= S (S y)); - apply le_S; apply Gt.gt_le_S; change (x < S y); - apply Lt.le_lt_n_Sm; exact H. -Qed. - -Inductive max_type (m n:nat) : Set := - cmt : forall v, m <= v -> n <= v -> max_type m n. - -Definition max : forall m n:nat, max_type m n. -intros m n; case (Compare_dec.le_gt_dec m n). -intros h; exists n; [exact h | apply le_n]. -intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h]. -Defined. diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml deleted file mode 100644 index b13bea9d..00000000 --- a/contrib/funind/functional_principles_proofs.ml +++ /dev/null @@ -1,1658 +0,0 @@ -open Printer -open Util -open Term -open Termops -open Names -open Declarations -open Pp -open Entries -open Hiddentac -open Evd -open Tacmach -open Proof_type -open Tacticals -open Tactics -open Indfun_common -open Libnames - -let msgnl = Pp.msgnl - - -let observe strm = - if do_observe () - then Pp.msgnl strm - else () - -let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end - else () - - - - -let do_observe_tac s tac g = - try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with e -> - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; - -let observe_tac_stream s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - -let observe_tac s tac g = observe_tac_stream (str s) tac g - -(* let tclTRYD tac = *) -(* if !Flags.debug || do_observe () *) -(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *) -(* else tac *) - - -let list_chop ?(msg="") n l = - try - list_chop n l - with Failure (msg') -> - failwith (msg ^ msg') - - -let make_refl_eq type_of_t t = - let refl_equal_term = Lazy.force refl_equal in - mkApp(refl_equal_term,[|type_of_t;t|]) - - -type pte_info = - { - proving_tac : (identifier list -> Tacmach.tactic); - is_valid : constr -> bool - } - -type ptes_info = pte_info Idmap.t - -type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : identifier list ; - eq_hyps : identifier list; - info : 'a - } - -type body_info = constr dynamic_info - - -let finish_proof dynamic_infos g = - observe_tac "finish" - ( h_assumption) - g - - -let refine c = - Tacmach.refine_no_check c - -let thin l = - Tacmach.thin_no_check l - - -let cut_replacing id t tac :tactic= - tclTHENS (cut t) - [ tclTHEN (thin_no_check [id]) (introduction_no_check id); - tac - ] - -let intro_erasing id = tclTHEN (thin [id]) (introduction id) - - - -let rec_hyp_id = id_of_string "rec_hyp" - -let is_trivial_eq t = - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - eq_constr t1 t2 - | _ -> false - - -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 - in - (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && - ( - not (eq_constr c1 c2) || - List.exists2 incompatible_constructor_terms arg1 arg2 - ) - -let is_incompatible_eq t = - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - incompatible_constructor_terms t1 t2 - | _ -> false - -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) - [tclTHENLIST - [ - (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); - (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) - ]] g - -exception TOREMOVE - - -let prove_trivial_eq h_id context (type_of_term,term) = - let nb_intros = List.length context in - tclTHENLIST - [ - tclDO nb_intros intro; (* introducing context *) - (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(Lazy.force refl_equal,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - -let isAppConstruct t = - if isApp t - then isConstruct (fst (destApp t)) - else false - -let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty - - -let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = - let nochange msg = - begin -(* observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ); *) - failwith "NoChange"; - end - in - let eq_constr = Reductionops.is_conv env sigma in - if not (noccurn 1 end_of_type) - then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp t) then nochange "not an equality"; - let f_eq,args = destApp t in - if not (eq_constr f_eq (Lazy.force eq)) then nochange "not an equality"; - let t1 = args.(1) - and t2 = args.(2) - and t1_typ = args.(0) - in - if not (closed0 t1) then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = -(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 - then - let t2 = destRel t2 in - begin - try - let t1' = Intmap.find t2 sub in - if not (eq_constr t1 t1') then nochange "twice bound variable"; - sub - with Not_found -> - assert (closed0 t1); - Intmap.add t2 t1 sub - end - else if isAppConstruct t1 && isAppConstruct t2 - then - begin - let c1,args1 = destApp t1 - and c2,args2 = destApp t2 - in - if not (eq_constr c1 c2) then anomaly "deconstructing equation"; - array_fold_left2 compute_substitution sub args1 args2 - end - else - if (eq_constr t1 t2) then sub else nochange "cannot solve" - in - let sub = compute_substitution Intmap.empty t1 t2 in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 - Can be safely replaced by the next comment for Ocaml >= 3.08.4 - *) - let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in - let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in - List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) - end_of_type_with_pop - sub'' - in - let old_context_length = List.length context + 1 in - let witness_fun = - mkLetIn(Anonymous,make_refl_eq t1_typ t1,t, - mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) - ) - in - let new_type_of_hyp,ctxt_size,witness_fun = - list_fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> - try - let witness = Intmap.find i sub in - if b' <> None then anomaly "can not redefine a rel!"; - (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) - with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) - ) - 1 - (new_end_of_type,0,witness_fun) - context - in - let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in - let new_ctxt,new_end_of_type = - Sign.decompose_prod_n_assum ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size intro) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - refine to_refine g - ) - in - let simpl_eq_tac = - change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp - in -(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) -(* str "removing an equation " ++ fnl ()++ *) -(* str "old_typ_of_hyp :=" ++ *) -(* Printer.pr_lconstr_env *) -(* env *) -(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) -(* ++ fnl () ++ *) -(* str "new_typ_of_hyp := "++ *) -(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) -(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) -(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) -(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) -(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) -(* ); *) - new_ctxt,new_end_of_type,simpl_eq_tac - - -let is_property ptes_info t_x full_type_of_hyp = - if isApp t_x - then - let pte,args = destApp t_x in - if isVar pte && array_for_all closed0 args - then - try - let info = Idmap.find (destVar pte) ptes_info in - info.is_valid full_type_of_hyp - with Not_found -> false - else false - else false - -let isLetIn t = - match kind_of_term t with - | LetIn _ -> true - | _ -> false - - -let h_reduce_with_zeta = - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - - - -let rewrite_until_var arg_num eq_ids : tactic = - (* tests if the declares recursive argument is neither a Constructor nor - an applied Constructor since such a form for the recursive argument - will break the Guard when trying to save the Lemma. - *) - let test_var g = - let _,args = destApp (pf_concl g) in - not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) - in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g - else - match eq_ids with - | [] -> anomaly "Cannot find a way to prove recursive property"; - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Equality.rewriteRL (mkVar eq_id))) - (do_rewrite eq_ids) - g - in - do_rewrite eq_ids - - -let rec_pte_id = id_of_string "Hrec" -let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in - let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then - let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in - let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in - (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp - in - tclTHENLIST - [ - h_reduce_with_zeta - (Tacticals.onHyp hyp_id) - ; - scan_type new_context new_typ_of_hyp - - ] - else if isProd type_of_hyp - then - begin - let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in - if is_property ptes_infos t_x actual_real_type_of_hyp then - begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length intro; - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in -(* observe_tac "rec hyp " *) - (tclTHENS - (assert_tac (Name rec_pte_id) t_x) - [ - (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps); -(* observe_tac "prove rec hyp" *) - (refine to_refine) - ]) - g - ) - ] - in - tclTHENLIST - [ -(* observe_tac "hyp rec" *) - (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr t_x coq_False then - begin -(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) -(* str " since it has False in its preconds " *) -(* ); *) - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr t_x coq_True (* Trivial => we remove this precons *) - then -(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) -(* str " removing useless precond True" *) -(* ); *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro intro; - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial" *) prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let _,args = destApp t_x in - tclTHENLIST - [ - change_hyp_with_using - "prove_trivial_eq" - hyp_id - real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (args.(0),args.(1)))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with Failure "NoChange" -> - (* Last thing todo : push the rel in the context and continue *) - scan_type ((x,None,t_x)::context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq ptes_infos continue_tac dyn_infos = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) - ] - g - -let heq_id = id_of_string "Heq" - -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let heq_id = pf_get_new_id heq_id g in - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); - (* Then the equation itself *) - introduction_no_check heq_id; - (* Then the new hypothesis *) - tclMAP introduction_no_check dyn_infos.rec_hyps; - (* observe_tac "after_introduction" *)(fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_type_of g' (mkVar heq_id) in - (* compute the new value of the body *) - let new_term_value = - match kind_of_term new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_lconstr_env (pf_env g') new_term_value_eq - ); - anomaly "cannot compute new term value" - in - let fun_body = - mkLambda(Anonymous, - pf_type_of g' term, - replace_term term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - ) - ] - g - - -let my_orelse tac1 tac2 g = - try - tac1 g - with e -> -(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) - tac2 g - -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = - my_orelse - ( (* we instanciate the hyp if possible *) - fun g -> - let prov_hid = pf_get_new_id hid g in - tclTHENLIST[ - pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); - thin [hid]; - h_rename [prov_hid,hid] - ] g - ) - ( (* - if not then we are in a mutual function block - and this hyp is a recursive hyp on an other function. - - We are not supposed to use it while proving this - principle so that we can trash it - - *) - (fun g -> -(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g - ) - ) - in - if args_id = [] - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; - do_prove hyps - ] - else - tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; - tclMAP instanciate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty - in - let remaining_hyps = - List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] - -let build_proof - (interactive_proof:bool) - (fnames:constant list) - ptes_infos - dyn_infos - : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = - fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = - mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (pf_concl g) in - let type_of_term = pf_type_of g t in - let term_eq = - make_refl_eq type_of_term t - in - tclTHENSEQ - [ - h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); - thin dyn_infos.rec_hyps; - pattern_option [(false,[1]),t] None; - h_simplest_case t; - (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instanciate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ] g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> - begin - match kind_of_term( pf_concl g) with - | Prod _ -> - tclTHEN - intro - (fun g' -> - let (id,_,_) = pf_last_hyp g' in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - {new_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in -(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *) - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app dyn_infos.info in - begin - match kind_of_term f with - | App _ -> assert false (* we have collected all the app in decompose_app *) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - build_proof_args do_finalize new_infos g - | Const c when not (List.mem c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in -(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | Lambda _ -> - let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} - g - | LetIn _ -> - let new_infos = - { dyn_infos with info = nf_betaiotazeta dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; - build_proof do_finalize new_infos - ] - g - | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with - info = dyn_infos.info,args - } - in - build_proof_args do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f } g - end - | Fix _ | CoFix _ -> - error ( "Anonymous local (co)fixpoints are not handled yet") - - | Prod _ -> error "Prod" - | LetIn _ -> - let new_infos = - { dyn_infos with - info = nf_betaiotazeta dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; - build_proof do_finalize new_infos - ] g - | Rel _ -> anomaly "Free var in goal conclusion !" - and build_proof do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g - and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> - let (f_args',args) = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} g - | arg::args -> -(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) -(* fnl () ++ *) -(* pr_goal (Tacmach.sig_it g) *) -(* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - (build_proof_args - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in - build_proof do_finalize - {dyn_infos with info = arg } - g - in - (* observe_tac "build_proof_args" *) (tac ) g - in - let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq - ptes_infos - finish_proof dyn_infos) - in - (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) - - - - - - - - - - - - -(* Proof of principles from structural functions *) -let is_pte_type t = - isSort (snd (decompose_prod t)) - -let is_pte (_,_,t) = is_pte_type t - - - - -type static_fix_info = - { - idx : int; - name : identifier; - types : types; - offset : int; - nb_realargs : int; - body_with_param : constr; - num_in_block : int - } - - - -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN - (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - )) - -let prove_rec_hyp fix_info = - { proving_tac = prove_rec_hyp_for_struct fix_info - ; - is_valid = fun _ -> true - } - - -exception Not_Rec - -let generalize_non_dep hyp g = -(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_type_of g (mkVar hyp) in - let to_revert,_ = - Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> - if List.mem hyp hyps - or List.exists (occur_var_in_decl env hyp) keep - or occur_var env hyp hyp_typ - or Termops.is_section_variable hyp (* should be dangerous *) - then (clear,decl::keep) - else (hyp::clear,keep)) - ~init:([],[]) (pf_env g) - in -(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) - tclTHEN - ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) - ((* observe_tac "thin" *) (thin to_revert)) - g - -let id_of_decl (na,_,_) = (Nameops.out_name na) -let var_of_decl decl = mkVar (id_of_decl decl) -let revert idl = - tclTHEN - (generalize (List.map mkVar idl)) - (thin idl) - -let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = -(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) -(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) -(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (destConst f) in - let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let f_body = - force (Option.get f_def.const_body) - in - let params,f_body_with_params = decompose_lam_n nb_params f_body in - let (_,num),(_,_,bodies) = destFix f_body_with_params in - let fnames_with_params = - let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in - let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in - fnames - in -(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *) -(* observe (str "body " ++ pr_lconstr bodies.(num)); *) - let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in -(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) - let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in -(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) - (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in - let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in - let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in - let f_id = id_of_label (con_label (destConst f)) in - let prove_replacement = - tclTHENSEQ - [ - tclDO (nb_params + rec_args_num + 1) intro; - (* observe_tac "" *) (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENSEQ - [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); - (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings)); - intros_reflexivity] g - ) - ] - in - Command.start_proof - (*i The next call to mk_equation_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - (mk_equation_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - lemma_type - (fun _ _ -> ()); - Pfedit.by (prove_replacement); - Command.save_named false - - - - -let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = - let equation_lemma = - try - let finfos = find_Function_infos (destConst f) in - mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> - let f_id = id_of_label (con_label (destConst f)) in - (*i The next call to mk_equation_id is valid since we will construct the lemma - Ensures by: obvious - i*) - let equation_lemma_id = (mk_equation_id f_id) in - generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; - let _ = - match e with - | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in - update_Function - {finfos with - equation_lemma = Some (match Nametab.locate (make_short_qualid equation_lemma_id) with - ConstRef c -> c - | _ -> Util.anomaly "Not a constant" - ) - } - | _ -> () - - in - Tacinterp.constr_of_id (pf_env g) equation_lemma_id - in - let nb_intro_to_do = nb_prod (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do intro) - ( - fun g' -> - let just_introduced = nLastHyps nb_intro_to_do g' in - let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in - tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' - ) - g - -let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (string_of_id id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - (Name new_id) - ) - in - let fresh_decl = - (fun (na,b,t) -> - (fresh_id na,b,t) - ) - in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let get_body const = - match (Global.lookup_constant const ).const_body with - | Some b -> - let body = force b in - Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) - body - | None -> error ( "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = - if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in - (full_params, (* real params *) - princ_params, (* the params of the principle which are not params of the function *) - substl (* function instanciated with real params *) - (List.map var_of_decl full_params) - f_body - ) - else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - (princ_info.params, (* real params *) - [],(* all params are full params *) - substl (* function instanciated with real params *) - (List.map var_of_decl princ_info.params) - f_body - ) - in -(* observe (str "full_params := " ++ *) -(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) -(* full_params *) -(* ); *) -(* observe (str "princ_params := " ++ *) -(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) -(* princ_params *) -(* ); *) -(* observe (str "fbody_with_full_params := " ++ *) -(* pr_lconstr fbody_with_full_params *) -(* ); *) - let all_funs_with_full_params = - Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota Evd.empty - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) - ) - bodies - in - let info_array = - Array.mapi - (fun i types -> - let types = prod_applist types (List.rev_map var_of_decl princ_params) in - { idx = idxs.(i) - fix_offset; - name = Nameops.out_name (fresh_id names.(i)); - types = types; - offset = fix_offset; - nb_realargs = - List.length - (fst (decompose_lam bodies.(i))) - fix_offset; - body_with_param = bodies_with_all_params.(i); - num_in_block = i - } - ) - typess - in - let pte_to_fix,rev_info = - list_fold_left_i - (fun i (acc_map,acc_info) (pte,_,_) -> - let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in - let nargs = List.length type_args in - let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in - let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in - let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota Evd.empty ( - applist(body,List.rev_map var_of_decl full_params)) - in - match kind_of_term body_with_full_params with - | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota Evd.empty - ( - (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) - bs.(num), - List.rev_map var_of_decl princ_params)) - ),num - | _ -> error "Not a mutual block" - in - let info = - {infos with - types = compose_prod type_args app_pte; - body_with_param = body_with_param; - num_in_block = num - } - in -(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) -(* str " to " ++ Ppconstr.pr_id info.name); *) - (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) - ) - 0 - (Idmap.empty,[]) - (List.rev princ_info.predicates) - in - pte_to_fix,List.rev rev_info - | _ -> Idmap.empty,[] - in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | [],[] -> tclIDTAC - | _, this_fix_info::others_infos -> - let other_fix_infos = - List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) - (pre_info@others_infos) - in - if other_fix_infos = [] - then - (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) - else - h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos - | _ -> anomaly "Not a valid information" - in - let first_tac : tactic = (* every operations until fix creations *) - tclTHENSEQ - [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); - (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); - (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); - (* observe_tac "building fixes" *) mk_fixes; - ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt,pte_app = (Sign.decompose_prod_assum (pf_concl gl)) in - let pte,pte_args = (decompose_app pte_app) in - try - let pte = try destVar pte with _ -> anomaly "Property is not a variable" in - let fix_info = Idmap.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENSEQ - [ - (* observe_tac ("introducing args") *) (tclDO nb_args intro); - (fun g -> (* replacement of the function by its body *) - let args = nLastHyps nb_args g in - let fix_body = fix_info.body_with_param in -(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota Evd.empty - (applist(fix_body,List.rev_map mkVar args_id)); - eq_hyps = [] - } - in - tclTHENSEQ - [ -(* observe_tac "do_replace" *) - (do_replace - full_params - (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block - all_funs - ); -(* observe_tac "do_replace" *) -(* (do_replace princ_info.params fix_info.idx args_id *) -(* (List.hd (List.rev pte_args)) fix_body); *) - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - (* observe_tac "cleaning" *) (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos) - in -(* observe (str "branches := " ++ *) -(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) -(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - -(* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) - ] - g - ); - ] gl - with Not_found -> - let nb_args = min (princ_info.nargs) (List.length ctxt) in - tclTHENSEQ - [ - tclDO nb_args intro; - (fun g -> (* replacement of the function by its body *) - let args = nLastHyps nb_args g in - let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = - { - nb_rec_hyps = -100; - rec_hyps = []; - info = - Reductionops.nf_betaiota Evd.empty - (applist(fbody_with_full_params, - (List.rev_map var_of_decl princ_params)@ - (List.rev_map mkVar args_id) - )); - eq_hyps = [] - } - in - let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in - tclTHENSEQ - [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; - let do_prove = - build_proof - interactive_proof - (Array.to_list fnames) - (Idmap.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - {dyn_infos with - rec_hyps = branches; - nb_rec_hyps = List.length branches - } - in - clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove - dyn_infos - in - instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id) - ] - g - ) - ] - gl - in - tclTHEN - first_tac - intros_after_fixes - g - - - - - - -(* Proof of principles of general functions *) -let h_id = Recdef.h_id -and hrec_id = Recdef.hrec_id -and acc_inv_id = Recdef.acc_inv_id -and ltof_ref = Recdef.ltof_ref -and acc_rel = Recdef.acc_rel -and well_founded = Recdef.well_founded -and delayed_force = Recdef.delayed_force -and h_intros = Recdef.h_intros -and list_rewrite = Recdef.list_rewrite -and evaluable_of_global_reference = Recdef.evaluable_of_global_reference - - - - - -let prove_with_tcc tcc_lemma_constr eqs : tactic = - match !tcc_lemma_constr with - | None -> anomaly "No tcc proof !!" - | Some lemma -> - fun gls -> -(* let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in *) -(* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENSEQ - [ -(* generalize [lemma]; *) -(* h_intro hid; *) -(* Elim.h_decompose_and (mkVar hid); *) - tclTRY(list_rewrite true eqs); -(* (fun g -> *) -(* let ids' = pf_ids_of_hyps g in *) -(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) -(* rewrite *) -(* ) *) - Eauto.gen_eauto false (false,5) [] (Some []) - ] - gls - - -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST (List.map Equality.rewriteRL eqs ) - in - let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in - let f_app = array_last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = array_last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with - | App(f',_) when eq_constr f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls - - - -let build_clause eqs = - { - Tacexpr.onhyps = - Some (List.map - (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) - eqs - ); - Tacexpr.concl_occs = Rawterm.no_occurrences_expr - } - -let rec rewrite_eqs_in_eqs eqs = - match eqs with - | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) - (tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false)) - gl - ) - eqs - ) - (rewrite_eqs_in_eqs eqs) - -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENSEQ - [ - backtrack_eqs_until_hrec hrec eqs; - (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) - (tclTHENS (* We must have exactly ONE subgoal !*) - (apply (mkVar hrec)) - [ tclTHENSEQ - [ - keep (tcc_hyps@eqs); - apply (Lazy.force acc_inv); - (fun g -> - if is_mes - then - unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g - else tclIDTAC g - ); - observe_tac "rew_and_finish" - (tclTHENLIST - [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); - observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); - (observe_tac "finishing using" - ( - tclCOMPLETE( - Eauto.eauto_with_bases - false - (true,5) - [Lazy.force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] - ) - ) - ) - ] - ) - ] - ]) - ]) - gls - - -let is_valid_hypothesis predicates_name = - let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in - let is_pte typ = - if isApp typ - then - let pte,_ = destApp typ in - if isVar pte - then Idset.mem (destVar pte) predicates_name - else false - else false - in - let rec is_valid_hypothesis typ = - is_pte typ || - match kind_of_term typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false - in - is_valid_hypothesis - -let prove_principle_for_gen - (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (string_of_id id) - | Anonymous -> fresh_id !avoid "H" - in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl (na,b,t) = (fresh_id na,b,t) in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; - args = List.map fresh_decl princ_info.args - } - in - let wf_tac = - if is_mes - then - (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) - else fun _ -> prove_with_tcc tcc_lemma_ref [] - in - let real_rec_arg_num = rec_arg_num - princ_info.nparams in - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in -(* observe ( *) -(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) -(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - -(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) -(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) -(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) -(* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = - Util.list_chop npost_rec_arg princ_info.args - in - let rec_arg_id = - match List.rev post_rec_arg with - | (Name id,_,_)::_ -> id - | _ -> assert false - in -(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in - let relation = substl subst_constrs relation in - let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in - let acc_rec_arg_id = - Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) - in - let revert l = - tclTHEN (h_generalize (List.map mkVar l)) (clear l) - in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - (tclCOMPLETE - (tclTHEN - (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) - ( - (* observe_tac *) -(* "apply wf_thm" *) - h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])) - ) - ) - ) - ) - g - in - let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in - let lemma = - match !tcc_lemma_ref with - | None -> anomaly ( "No tcc proof !!") - | Some lemma -> lemma - in -(* let rec list_diff del_list check_list = *) -(* match del_list with *) -(* [] -> *) -(* [] *) -(* | f::r -> *) -(* if List.mem f check_list then *) -(* list_diff r check_list *) -(* else *) -(* f::(list_diff r check_list) *) -(* in *) - let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_global_ident_away true - (id_of_string "prov") - hyps - in - tclTHENSEQ - [ - generalize [lemma]; - h_intro hid; - Elim.h_decompose_and (mkVar hid); - (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); - if !tcc_list = [] - then - begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g - ) - ] - gls - in - tclTHENSEQ - [ - observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (fun (na,_,_) -> Nameops.out_name na) - (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) - ); - (* observe_tac "" *) (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (prove_rec_arg_acc) - ); -(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) -(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) - h_intros (List.rev (acc_rec_arg_id::args_ids)); - Equality.rewriteLR (mkConst eq_ref); - (* observe_tac "finish" *) (fun gl' -> - let body = - let _,args = destApp (pf_concl gl') in - array_last args - in - let body_info rec_hyps = - { - nb_rec_hyps = List.length rec_hyps; - rec_hyps = rec_hyps; - eq_hyps = []; - info = body - } - in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = - List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> -(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) -(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) -(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) -(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) -(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - - (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (fun (na,_,_) -> (Nameops.out_name na)) - (princ_info.args@princ_info.params) - )@ ([acc_rec_arg_id])) eqs - ) - - ); - is_valid = is_valid_hypothesis predicates_names - } - in - let ptes_info : pte_info Idmap.t = - List.fold_left - (fun map pte_id -> - Idmap.add pte_id - pte_info - map - ) - Idmap.empty - predicates_names - in - let make_proof rec_hyps = - build_proof - false - [f_ref] - ptes_info - (body_info rec_hyps) - in - (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args - make_proof - (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) - (List.rev args_ids) - ) - gl' - ) - - ] - gl - - - - - - - - diff --git a/contrib/funind/functional_principles_proofs.mli b/contrib/funind/functional_principles_proofs.mli deleted file mode 100644 index 62eb528e..00000000 --- a/contrib/funind/functional_principles_proofs.mli +++ /dev/null @@ -1,19 +0,0 @@ -open Names -open Term - -val prove_princ_for_struct : - bool -> - int -> constant array -> constr array -> int -> Tacmach.tactic - - -val prove_principle_for_gen : - constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) - constr option ref -> (* a pointer to the obligation proofs lemma *) - bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) - types -> (* the type of the recursive argument *) - constr -> (* the wf relation used to prove the function *) - Tacmach.tactic - - -(* val is_pte : rel_declaration -> bool *) diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml deleted file mode 100644 index b03bdf31..00000000 --- a/contrib/funind/functional_principles_types.ml +++ /dev/null @@ -1,733 +0,0 @@ -open Printer -open Util -open Term -open Termops -open Names -open Declarations -open Pp -open Entries -open Hiddentac -open Evd -open Tacmach -open Proof_type -open Tacticals -open Tactics -open Indfun_common -open Functional_principles_proofs - -exception Toberemoved_with_rel of int*constr -exception Toberemoved - - -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in - msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl - - -let observe s = - if do_observe () - then Pp.msgnl s - - -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in - msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl - - -let observe s = - if do_observe () - then Pp.msgnl s - -(* - Transform an inductive induction principle into - a functional one -*) -let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in - let env = Global.env () in - let env_with_params = Environ.push_rel_context princ_type_info.params env in - let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:identifier list) (predicates:Sign.rel_context) : Sign.rel_context = - match predicates with - | [] -> [] - |(Name x,v,t)::predicates -> - let id = Nameops.next_ident_away x avoid in - Hashtbl.add tbl id x; - (Name id,v,t)::(change_predicates_names (id::avoid) predicates) - | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " - in - let avoid = (Termops.ids_of_context env_with_params ) in - let princ_type_info = - { princ_type_info with - predicates = change_predicates_names avoid princ_type_info.predicates - } - in -(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) -(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) - let change_predicate_sort i (x,_,t) = - let new_sort = sorts.(i) in - let args,_ = decompose_prod t in - let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args - in - Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) - in - let new_predicates = - list_map_i - change_predicate_sort - 0 - princ_type_info.predicates - in - let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in - let rel_as_kn = - fst (match princ_type_info.indref with - | Some (Libnames.IndRef ind) -> ind - | _ -> error "Not a valid predicate" - ) - in - let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in - let is_pte = - let set = List.fold_right Idset.add ptes_vars Idset.empty in - fun t -> - match kind_of_term t with - | Var id -> Idset.mem id set - | _ -> false - in - let pre_princ = - it_mkProd_or_LetIn - ~init: - (it_mkProd_or_LetIn - ~init:(Option.fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) - princ_type_info.branches - in - let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in - let is_dom c = - match kind_of_term c with - | Ind((u,_)) -> u = rel_as_kn - | Construct((u,_),_) -> u = rel_as_kn - | _ -> false - in - let get_fun_num c = - match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num - | _ -> assert false - in - let dummy_var = mkVar (id_of_string "________") in - let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in -(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) - res - in - let rec has_dummy_var t = - fold_constr - (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t)) - false - t - in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = - match kind_of_term pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | _,_,t when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (array_last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applist(new_f, new_args), - list_union_eq eq_constr binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] - in -(* let _ = match kind_of_term pre_princ with *) -(* | Prod _ -> *) -(* observe(str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl ()) *) -(* | _ -> () in *) - res - - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : name = get_name (ids_of_context env) x in - let new_env = Environ.push_rel (x,None,t) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - eq_constr - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x : name = get_name (ids_of_context env) x in - let new_env = Environ.push_rel (x,Some v,t) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - eq_constr - (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc - in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ - in - let pre_res = - replace_vars - (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) - (lift (List.length ptes_vars) pre_res) - in - it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn - ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) - new_predicates) - ) - princ_type_info.params - - - -let change_property_sort toSort princ princName = - let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = - (x,None, - let args,_ = decompose_prod t in - compose_prod args (mkSort toSort) - ) - in - let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(princName_as_constr, - Array.init nargs - (fun i -> mkRel (nargs - i ))) - in - it_mkLambda_or_LetIn - ~init: - (it_mkLambda_or_LetIn ~init - (List.map change_sort_in_predicate princ_info.predicates) - ) - princ_info.params - - -let pp_dur time time' = - str (string_of_float (System.time_difference time time')) - -(* let qed () = save_named true *) -let defined () = - try - Command.save_named false - with - | UserError("extract_proof",msg) -> - Util.errorlabstrm - "defined" - ((try - str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () - with _ -> mt () - ) ++msg) - | e -> raise e - - - -let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = - (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in - (* let time1 = System.get_time () in *) - let new_principle_type = - compute_new_princ_type_from_rel - (Array.map mkConst funs) - sorts - old_princ_type - in - (* let time2 = System.get_time () in *) - (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - (* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) - let new_princ_name = - next_global_ident_away true (id_of_string "___________princ_________") [] - in - begin - Command.start_proof - new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type - (hook new_principle_type) - ; - (* let _tim1 = System.get_time () in *) - Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) - get_proof_clean true - end - - - -let generate_functional_principle - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = - try - let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) - | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id - | None -> - let id_of_f = id_of_label (con_label f) in - id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) - in - let names = ref [new_princ_name] in - let hook new_principle_type _ _ = - if sorts = None - then - (* let id_of_f = id_of_label (con_label f) in *) - let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let value = change_property_sort s new_principle_type new_princ_name in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = - { const_entry_body = value; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() - } - in - ignore( - Declare.declare_constant - name - (Entries.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme) - ) - ); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) - name; - names := name :: !names - in - register_with_sort InProp; - register_with_sort InSet - in - let (id,(entry,g_kind,hook)) = - build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook - in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - save false new_princ_name entry g_kind hook - with e -> - begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" - then Pfedit.delete_current_proof () - else () - else () - with _ -> () - end; - raise (Defining_principle e) - end -(* defined () *) - - -exception Not_Rec - -let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = - match kind_of_term (snd (decompose_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na with - | Name id -> - let const = make_con mp dp (label_of_id id) in - const,i - | Anonymous -> - anomaly "Anonymous fix" - ) - na - | _ -> [|const,0|] - in - function const -> - let find_constant_body const = - match (Global.lookup_constant const ).const_body with - | Some b -> - let body = force b in - let body = Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) - body - in - body - | None -> error ( "Cannot define a principle over an axiom ") - in - let f = find_constant_body const in - let l_const = get_funs_constant const f in - (* - We need to check that all the functions found are in the same block - to prevent Reset stange thing - *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the paremeter must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not ((=) first_params params) - then error "Not a mutal recursive block" - ) - l_params - in - (* The bodies has to be very similar *) - let _check_bodies = - try - let extract_info is_first body = - match kind_of_term body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && (List.length l_bodies = 1) - then raise Not_Rec - else error "Not a mutal recursive block" - in - let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) - if not (first_infos = (extract_info false body)) - then error "Not a mutal recursive block" - in - List.iter check l_bodies - with Not_Rec -> () - in - l_const - -exception No_graph_found -exception Found_type of int - -let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = - let env = Global.env () - and sigma = Evd.empty in - let funs = List.map fst fas in - let first_fun = List.hd funs in - - - let funs_mp,funs_dp,_ = Names.repr_con first_fun in - let first_fun_kn = - try - fst (find_Function_infos first_fun).graph_ind - with Not_found -> raise No_graph_found - in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in - let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.map - (function const -> List.assoc const this_block_funs_indexes) - funs - in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - let (mib,mip) = Global.lookup_inductive ind in - ind,mib,mip,true,prop_sort - ) - funs_indexes - in - let l_schemes = - List.map - (Typing.type_of env sigma) - (Indrec.build_mutual_indrec env sigma ind_list) - in - let i = ref (-1) in - let sorts = - List.rev_map (fun (_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fas - in - (* We create the first priciple by tactic *) - let first_type,other_princ_types = - match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> anomaly "" - in - let (_,(const,_,_)) = - try - build_functional_principle false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct false 0 (Array.of_list funs)) - (fun _ _ _ -> ()) - with e -> - begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" - then Pfedit.delete_current_proof () - else () - else () - with _ -> () - end; - raise (Defining_principle e) - end - - in - incr i; - let opacity = - let finfos = find_Function_infos this_block_funs.(0) in - try - let equation = Option.get finfos.equation_lemma in - (Global.lookup_constant equation).Declarations.const_opaque - with Option.IsNone -> (* non recursive definition *) - false - in - let const = {const with const_entry_opaque = opacity } in - (* The others are just deduced *) - if other_princ_types = [] - then - [const] - else - let other_fun_princ_types = - let funs = Array.map mkConst this_block_funs in - let sorts = Array.of_list sorts in - List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types - in - let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in - let ctxt,fix = Sign.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = destFix fix in - let other_result = - List.map (* we can now compute the other principles *) - (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr scheme_type); - let type_concl = snd (Sign.decompose_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in - let f = fst (decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = snd (Sign.decompose_prod_assum t) in - let applied_g = List.hd (List.rev (snd (decompose_app t))) in - let g = fst (decompose_app applied_g) in - if eq_constr f g - then raise (Found_type j); - observe (Printer.pr_lconstr f ++ str " <> " ++ - Printer.pr_lconstr g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let (_,(const,_,_)) = - build_functional_principle - false - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (prove_princ_for_struct false !i (Array.of_list funs)) - (fun _ _ _ -> ()) - in - const - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt - in - {const with - Entries.const_entry_body = princ_body; - Entries.const_entry_type = Some scheme_type - } - ) - other_fun_princ_types - in - const::other_result - -let build_scheme fas = - let bodies_types = - make_scheme - (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - match Nametab.global f with - | Libnames.ConstRef c -> c - | _ -> Util.error "Functional Scheme can only be used with functions" - with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f) - in - (f_as_constant,sort) - ) - fas - ) - in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - princ_id - (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id - ) - fas - bodies_types - - - -let build_case_scheme fa = - let env = Global.env () - and sigma = Evd.empty in -(* let id_to_constr id = *) -(* Tacinterp.constr_of_id env id *) -(* in *) - let funs = (fun (_,f,_) -> - try Libnames.constr_of_global (Nametab.global f) - with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in - - let funs_mp,funs_dp,_ = Names.repr_con first_fun in - let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - - - - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in - let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc (destConst funs) this_block_funs_indexes - in - let ind_fun = - let ind = first_fun_kn,funs_indexes in - ind,prop_sort - in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in - let sorts = - (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fa - in - let princ_name = (fun (x,_,_) -> x) fa in - let _ = -(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) -(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) -(* ); *) - generate_functional_principle - false - scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (prove_princ_for_struct false 0 [|destConst funs|]) - in - () diff --git a/contrib/funind/functional_principles_types.mli b/contrib/funind/functional_principles_types.mli deleted file mode 100644 index cf28c6e6..00000000 --- a/contrib/funind/functional_principles_types.mli +++ /dev/null @@ -1,34 +0,0 @@ -open Names -open Term - - -val generate_functional_principle : - (* do we accept interactive proving *) - bool -> - (* induction principle on rel *) - types -> - (* *) - sorts array option -> - (* Name of the new principle *) - (identifier) option -> - (* the compute functions to use *) - constant array -> - (* We prove the nth- principle *) - int -> - (* The tactic to use to make the proof w.r - the number of params - *) - (constr array -> int -> Tacmach.tactic) -> - unit - -val compute_new_princ_type_from_rel : constr array -> sorts array -> - types -> types - - -exception No_graph_found - -val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list - -val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list -> unit -val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort) -> unit - diff --git a/contrib/funind/g_indfun.ml4 b/contrib/funind/g_indfun.ml4 deleted file mode 100644 index a79b46d9..00000000 --- a/contrib/funind/g_indfun.ml4 +++ /dev/null @@ -1,524 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) -open Util -open Term -open Names -open Pp -open Topconstr -open Indfun_common -open Indfun -open Genarg -open Pcoq -open Tacticals - -let pr_binding prc = function - | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) - -let pr_bindings prc prlc = function - | Rawterm.ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc prc l - | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Rawterm.NoBindings -> mt () - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - -let pr_fun_ind_using prc prlc _ opt_c = - match opt_c with - | None -> mt () - | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b)) - -(* Duplication of printing functions because "'a with_bindings" is - (internally) not uniform in 'a: indeed constr_with_bindings at the - "typed" level has type "open_constr with_bindings" instead of - "constr with_bindings"; hence, its printer cannot be polymorphic in - (prc,prlc)... *) - -let pr_with_bindings_typed prc prlc (c,bl) = - prc c ++ - hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c)) bl) - -let pr_fun_ind_using_typed prc prlc _ opt_c = - match opt_c with - | None -> mt () - | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b)) - - -ARGUMENT EXTEND fun_ind_using - TYPED AS constr_with_bindings_opt - PRINTED BY pr_fun_ind_using_typed - RAW_TYPED AS constr_with_bindings_opt - RAW_PRINTED BY pr_fun_ind_using - GLOB_TYPED AS constr_with_bindings_opt - GLOB_PRINTED BY pr_fun_ind_using -| [ "using" constr_with_bindings(c) ] -> [ Some c ] -| [ ] -> [ None ] -END - - -TACTIC EXTEND newfuninv - [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> - [ - Invfun.invfun hyp fname - ] -END - - -let pr_intro_as_pat prc _ _ pat = - match pat with - | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat - | None -> mt () - - -ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] -| [] ->[ None ] -END - - - - -TACTIC EXTEND newfunind - ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with - | [] -> assert false - | [c] -> c - | c::cl -> applist(c,cl) - in - functional_induction true c princl pat ] -END -(***** debug only ***) -TACTIC EXTEND snewfunind - ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with - | [] -> assert false - | [c] -> c - | c::cl -> applist(c,cl) - in - functional_induction false c princl pat ] -END - - -let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc - -ARGUMENT EXTEND constr_coma_sequence' - TYPED AS constr_list - PRINTED BY pr_constr_coma_sequence -| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ] -| [ constr(c) ] -> [ [c] ] -END - -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc - -ARGUMENT EXTEND auto_using' - TYPED AS constr_list - PRINTED BY pr_auto_using -| [ "using" constr_coma_sequence'(l) ] -> [ l ] -| [ ] -> [ [] ] -END - -let pr_rec_annotation2_aux s r id l = - str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ - Util.pr_opt Nameops.pr_id id ++ - Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" - -let pr_rec_annotation2 = function - | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}" - | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l - | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l - -VERNAC ARGUMENT EXTEND rec_annotation2 -PRINTED BY pr_rec_annotation2 - [ "{" "struct" ident(id) "}"] -> [ Struct id ] -| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] -| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] -END - -let pr_binder2 (idl,c) = - str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ - str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" - -VERNAC ARGUMENT EXTEND binder2 -PRINTED BY pr_binder2 - [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ] -END - -let make_binder2 (idl,c) = - LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) - -let pr_rec_definition2 (id,bl,annot,type_,def) = - Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ - Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ - Ppconstr.pr_lconstr_expr def - -VERNAC ARGUMENT EXTEND rec_definition2 -PRINTED BY pr_rec_definition2 - [ ident(id) binder2_list(bl) - rec_annotation2_opt(annot) ":" lconstr(type_) - ":=" lconstr(def)] -> - [ (id,bl,annot,type_,def) ] -END - -let make_rec_definitions2 (id,bl,annot,type_,def) = - let bl = List.map make_binder2 bl in - let names = List.map snd (Topconstr.names_of_local_assums bl) in - let check_one_name () = - if List.length names > 1 then - Util.user_err_loc - (Util.dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified"); - in - let check_exists_args an = - try - let id = match an with - | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id - | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" - in - (try ignore(Util.list_index0 (Name id) names); annot - with Not_found -> Util.user_err_loc - (Util.dummy_loc,"Function", - Pp.str "No argument named " ++ Nameops.pr_id id) - ) - with Failure "check_exists_args" -> check_one_name ();annot - in - let ni = - match annot with - | None -> - annot - | Some an -> - check_exists_args an - in - ((Util.dummy_loc,id), ni, bl, type_, def) - - -VERNAC COMMAND EXTEND Function - ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> - [ - do_generate_principle false (List.map make_rec_definitions2 recsl); - - ] -END - -let pr_fun_scheme_arg (princ_name,fun_name,s) = - Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ - Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Ppconstr.pr_rawsort s - -VERNAC ARGUMENT EXTEND fun_scheme_arg -PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] -END - - -let warning_error names e = - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ - if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | Defining_principle e -> - Pp.msg_warning - (str "Cannot define principle(s) for "++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ - if do_observe () then Cerrors.explain_exn e else mt ()) - | _ -> anomaly "" - - -VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> - [ - begin - try - Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - begin - match fas with - | (_,fun_name,_)::_ -> - begin - begin - make_graph (Nametab.global fun_name) - end - ; - try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> - Util.error ("Cannot generate induction principle(s)") - | e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e - - end - | _ -> assert false (* we can only have non empty list *) - end - | e -> - let names = List.map (fun (_,na,_) -> na) fas in - warning_error names e - - end - ] -END -(***** debug only ***) - -VERNAC COMMAND EXTEND NewFunctionalCase - ["Functional" "Case" fun_scheme_arg(fas) ] -> - [ - Functional_principles_types.build_case_scheme fas - ] -END - -(***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph -["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] -END - - - - - -(* FINDUCTION *) - -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" - (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); - msg(str ""); - end - - - -(** Information about an occurrence of a function call (application) - inside a term. *) -type fapp_info = { - fname: constr; (** The function applied *) - largs: constr list; (** List of arguments *) - free: bool; (** [true] if all arguments are debruijn free *) - max_rel: int; (** max debruijn index in the funcall *) - onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) -} - - -(** [constr_head_match(a b c) a] returns true, false otherwise. *) -let constr_head_match u t= - if isApp u - then - let uhd,args= destApp u in - uhd=t - else false - -(** [hdMatchSub inu t] returns the list of occurrences of [t] in - [inu]. DeBruijn are not pushed, so some of them may be unbound in - the result. *) -let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = - let subres = - match kind_of_term inu with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> - hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test - | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) - [] bl - | _ -> (* Cofix will be wrong *) - fold_constr - (fun l cstr -> - l @ hdMatchSub cstr test) [] inu in - if not (test inu) then subres - else - let f,args = decompose_app inu in - let freeset = Termops.free_rels inu in - let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in - {fname = f; largs = args; free = Util.Intset.is_empty freeset; - max_rel = max_rel; onlyvars = List.for_all isVar args } - ::subres - -let mkEq typ c1 c2 = - mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) - - -let poseq_unsafe idunsafe cstr gl = - let typ = Tacmach.pf_type_of gl cstr in - tclTHEN - (Tactics.letin_tac None (Name idunsafe) cstr None allClauses) - (tclTHENFIRST - (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) - Tactics.reflexivity) - gl - - -let poseq id cstr gl = - let x = Tactics.fresh_id [] id gl in - poseq_unsafe x cstr gl - -(* dirty? *) - -let list_constr_largs = ref [] - -let rec poseq_list_ids_rec lcstr gl = - match lcstr with - | [] -> tclIDTAC gl - | c::lcstr' -> - match kind_of_term c with - | Var _ -> - (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) - | _ -> - let _ = prstr "c = " in - let _ = prconstr c in - let _ = prstr "\n" in - let typ = Tacmach.pf_type_of gl c in - let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in - let x = Tactics.fresh_id [] cname gl in - let _ = list_constr_largs:=mkVar x :: !list_constr_largs in - let _ = prstr " list_constr_largs = " in - let _ = prlistconstr !list_constr_largs in - let _ = prstr "\n" in - - tclTHEN - (poseq_unsafe x c) - (poseq_list_ids_rec lcstr') - gl - -let poseq_list_ids lcstr gl = - let _ = list_constr_largs := [] in - poseq_list_ids_rec lcstr gl - -(** [find_fapp test g] returns the list of [app_info] of all calls to - functions that satisfy [test] in the conclusion of goal g. Trivial - repetition (not modulo conversion) are deleted. *) -let find_fapp (test:constr -> bool) g : fapp_info list = - let pre_res = hdMatchSub (Tacmach.pf_concl g) test in - let res = - List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in - (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); - res) - - - -(** [finduction id filter g] tries to apply functional induction on - an occurence of function [id] in the conclusion of goal [g]. If - [id]=[None] then calls to any function are selected. In any case - [heuristic] is used to select the most pertinent occurrence. *) -let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) - (nexttac:Proof_type.tactic) g = - let test = match oid with - | Some id -> - let idconstr = mkConst (const_of_id id) in - (fun u -> constr_head_match u idconstr) (* select only id *) - | None -> (fun u -> isApp u) in (* select calls to any function *) - let info_list = find_fapp test g in - let ordered_info_list = heuristic info_list in - prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); - if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; - let taclist: Proof_type.tactic list = - List.map - (fun info -> - (tclTHEN - (tclTHEN (poseq_list_ids info.largs) - ( - fun gl -> - (functional_induction - true (applist (info.fname, List.rev !list_constr_largs)) - None None) gl)) - nexttac)) ordered_info_list in - (* we try each (f t u v) until one does not fail *) - (* TODO: try also to mix functional schemes *) - tclFIRST taclist g - - - - -(** [chose_heuristic oi x] returns the heuristic for reordering - (and/or forgetting some elts of) a list of occurrences of - function calls infos to chose first with functional induction. *) -let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = - match oi with - | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) - | None -> - (* Default heuristic: put first occurrences where all arguments - are *bound* (meaning already introduced) variables *) - let ordering x y = - if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) - else if x.free && x.onlyvars then -1 - else if y.free && y.onlyvars then 1 - else 0 (* both not pertinent *) - in - List.sort ordering - - - -TACTIC EXTEND finduction - ["finduction" ident(id) natural_opt(oi)] -> - [ - match oi with - | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" - | _ -> - let heuristic = chose_heuristic oi in - finduction (Some id) heuristic tclIDTAC - ] -END - - - -TACTIC EXTEND fauto - [ "fauto" tactic(tac)] -> - [ - let heuristic = chose_heuristic None in - finduction None heuristic (snd tac) - ] - | - [ "fauto" ] -> - [ - let heuristic = chose_heuristic None in - finduction None heuristic tclIDTAC - ] - -END - - -TACTIC EXTEND poseq - [ "poseq" ident(x) constr(c) ] -> - [ poseq x c ] -END - -VERNAC COMMAND EXTEND Showindinfo - [ "showindinfo" ident(x) ] -> [ Merge.showind x ] -END - -VERNAC COMMAND EXTEND MergeFunind - [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" - "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> - [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Util.dummy_loc,id1))) in - let f2 = Constrintern.interp_constr Evd.empty (Global.env()) - (CRef (Libnames.Ident (Util.dummy_loc,id2))) in - let f1type = Typing.type_of (Global.env()) Evd.empty f1 in - let f2type = Typing.type_of (Global.env()) Evd.empty f2 in - let ar1 = List.length (fst (decompose_prod f1type)) in - let ar2 = List.length (fst (decompose_prod f2type)) in - let _ = - if ar1 <> List.length cl1 then - Util.error ("not the right number of arguments for " ^ string_of_id id1) in - let _ = - if ar2 <> List.length cl2 then - Util.error ("not the right number of arguments for " ^ string_of_id id2) in - Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id - ] -END diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml deleted file mode 100644 index b6b2cbd1..00000000 --- a/contrib/funind/indfun.ml +++ /dev/null @@ -1,752 +0,0 @@ -open Util -open Names -open Term -open Pp -open Indfun_common -open Libnames -open Rawterm -open Declarations - -let is_rec_info scheme_info = - let test_branche min acc (_,_,br) = - acc || ( - let new_branche = - Sign.it_mkProd_or_LetIn mkProp (fst (Sign.decompose_prod_assum br)) in - let free_rels_in_br = Termops.free_rels new_branche in - let max = min + scheme_info.Tactics.npredicates in - Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br - ) - in - Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) - - -let choose_dest_or_ind scheme_info = - if is_rec_info scheme_info - then Tactics.new_induct false - else Tactics.new_destruct false - - -let functional_induction with_clean c princl pat = - let f,args = decompose_app c in - fun g -> - let princ,bindings, princ_type = - match princl with - | None -> (* No principle is given let's find the good one *) - begin - match kind_of_term f with - | Const c' -> - let princ_option = - let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ - Printer.pr_lconstr (mkConst c') ) - in - match Tacticals.elimination_sort_of_goal g with - | InProp -> finfo.prop_lemma - | InSet -> finfo.rec_lemma - | InType -> finfo.rect_lemma - in - let princ = (* then we get the principle *) - try mkConst (Option.get princ_option ) - with Option.IsNone -> - (*i If there is not default lemma defined then, - we cross our finger and try to find a lemma named f_ind - (or f_rec, f_rect) i*) - let princ_name = - Indrec.make_elimination_ident - (id_of_label (con_label c')) - (Tacticals.elimination_sort_of_goal g) - in - try - mkConst(const_of_id princ_name ) - with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " - ++Printer.pr_lconstr (mkConst c') ) - in - (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) - | _ -> raise (UserError("",str "functional induction must be used with a function" )) - - end - | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_type_of g princ - in - let princ_infos = Tactics.compute_elim_sig princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> - try Idset.add (destVar a) acc - with _ -> acc - ) - args - Idset.empty - in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in - let subst_and_reduce g = - if with_clean - then - let idl = - map_succeed - (fun id -> - if Idset.mem id old_idl then failwith "subst_and_reduce"; - id - ) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - } - in - Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) - (Hiddentac.h_reduce flag Tacticals.allClauses) - g - else Tacticals.tclIDTAC g - - in - Tacticals.tclTHEN - (choose_dest_or_ind - princ_infos - args_as_induction_constr - princ' - (None,pat) - None) - subst_and_reduce - g - - - - -type annot = - Struct of identifier - | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list - | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list - - -type newfixpoint_expr = - identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr - -let rec abstract_rawconstr c = function - | [] -> c - | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl) - | Topconstr.LocalRawAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl - (abstract_rawconstr c bl) - -let interp_casted_constr_with_implicits sigma env impls c = -(* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *) - Constrintern.intern_gen false sigma env ~impls:([],impls) - ~allow_patvar:false ~ltacvars:([],[]) c - - -(* - Construct a fixpoint as a Rawterm - and not as a constr -*) -let build_newrecursive -(lnameargsardef) = - let env0 = Global.env() - and sigma = Evd.empty - in - let (rec_sign,rec_impls) = - List.fold_left - (fun (env,impls) ((_,recname),_,bl,arityc,_) -> - let arityc = Command.generalize_constr_expr arityc bl in - let arity = Constrintern.interp_type sigma env0 arityc in - let impl = - if Impargs.is_implicit_args() - then Impargs.compute_implicits env0 arity - else [] in - let impls' =(recname,(Constrintern.Recursive,[],impl,Notation.compute_arguments_scope arity))::impls in - (Environ.push_named (recname,None,arity) env, impls')) - (env0,[]) lnameargsardef in - let recdef = - (* Declare local notations *) - let fs = States.freeze() in - let def = - try - List.map - (fun (_,_,bl,_,def) -> - let def = abstract_rawconstr def bl in - interp_casted_constr_with_implicits - sigma rec_sign rec_impls def - ) - lnameargsardef - with e -> - States.unfreeze fs; raise e in - States.unfreeze fs; def - in - recdef,rec_impls - - -let compute_annot (name,annot,args,types,body) = - let names = List.map snd (Topconstr.names_of_local_assums args) in - match annot with - | None -> - if List.length names > 1 then - user_err_loc - (dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified"); - let new_annot = (id_of_name (List.hd names)) in - (name,Struct new_annot,args,types,body) - | Some r -> (name,r,args,types,body) - - -(* Checks whether or not the mutual bloc is recursive *) -let rec is_rec names = - let names = List.fold_right Idset.add names Idset.empty in - let check_id id names = Idset.mem id names in - let rec lookup names = function - | RVar(_,id) -> check_id id names - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false - | RCast(_,b,_) -> lookup names b - | RRec _ -> error "RRec not handled" - | RIf(_,b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> - lookup names t || lookup (Nameops.name_fold Idset.remove na names) b - | RLetTuple(_,nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.name_fold Idset.remove na acc) - names - nal - ) - b - | RApp(_,f,args) -> List.exists (lookup names) (f::args) - | RCases(_,_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names (_,idl,_,rt) = - let new_names = List.fold_right Idset.remove idl names in - lookup new_names rt - in - lookup names - -let prepare_body (name,annot,args,types,body) rt = - let n = (Topconstr.local_binders_length args) in -(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') - - -let derive_inversion fix_names = - try - (* we first transform the fix_names identifier into their corresponding constant *) - let fix_names_as_constant = - List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names - in - (* - Then we check that the graphs have been defined - If one of the graphs haven't been defined - we do nothing - *) - List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; - try - Invfun.derive_correctness - Functional_principles_types.make_scheme - functional_induction - fix_names_as_constant - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : register_built - i*) - (List.map - (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) - fix_names - ) - with e -> - msg_warning - (str "Cannot built inversion information" ++ - if do_observe () then Cerrors.explain_exn e else mt ()) - with _ -> () - -let warning_error names e = - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | Defining_principle e -> - Pp.msg_warning - (str "Cannot define principle(s) for "++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - if do_observe () then Cerrors.explain_exn e else mt ()) - | _ -> anomaly "" - -let error_error names e = - match e with - | Building_graph e -> - errorlabstrm "" - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | _ -> anomaly "" - -let generate_principle on_error - is_general do_built fix_rec_l recdefs interactive_proof - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in - let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in - let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in - try - (* We then register the Inductive graphs of the functions *) - Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in - let ind_kn = - fst (locate_with_msg - (pr_reference f_R_mut++str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn (fname,_,_,_,_) = - let f_ref = Ident fname in - locate_with_msg - (pr_reference f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - list_map_i - (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in - let princ_type = Typeops.type_of_constant (Global.env()) princ - in - Functional_principles_types.generate_functional_principle - interactive_proof - princ_type - None - None - funs_kn - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e -> - on_error names e - -let register_struct is_rec fixpoint_exprl = - match fixpoint_exprl with - | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> - Command.declare_definition - fname - (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition) - bl - None - body - (Some ret_type) - (fun _ _ -> ()) - | _ -> - Command.build_recursive fixpoint_exprl (Flags.boxed_definitions()) - -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = - Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation - - -let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = - let type_of_f = Command.generalize_constr_expr ret_type args in - let rec_arg_num = - let names = - List.map - snd - (Topconstr.names_of_local_assums args) - in - match wf_arg with - | None -> - if List.length names = 1 then 1 - else error "Recursive argument must be specified" - | Some wf_arg -> - list_index (Name wf_arg) names - in - let unbounded_eq = - let f_app_args = - Topconstr.CAppExpl - (dummy_loc, - (None,(Ident (dummy_loc,fname))) , - (List.map - (function - | _,Anonymous -> assert false - | _,Name e -> (Topconstr.mkIdentC e) - ) - (Topconstr.names_of_local_assums args) - ) - ) - in - Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), - [(f_app_args,None);(body,None)]) - in - let eq = Command.generalize_constr_expr unbounded_eq args in - let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type - nb_args relation = - try - pre_hook - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - ); - derive_inversion [fname] - with e -> - (* No proof done *) - () - in - Recdef.recursive_definition - is_mes fname rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - - -let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = - match wf_arg with - | None -> - begin - match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" - end - | Some wf_args -> - try - match - List.find - (function - | Topconstr.LocalRawAssum(l,k,t) -> - List.exists - (function (_,Name id) -> id = wf_args | _ -> false) - l - | _ -> false - ) - args - with - | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false - in - let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in - Libnames.Qualid (dummy_loc,Libnames.qualid_of_sp - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) - in - let fun_from_mes = - let applied_mes = - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) - in - let wf_rel_from_mes = - Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) - in - register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) - using_lemmas args ret_type body - - -let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let _is_struct = - match fixpoint_exprl with - | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> - let pre_hook = - generate_principle - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; - false - | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> - let pre_hook = - generate_principle - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; - true - | _ -> - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl - in - let is_one_rec = is_rec fix_names in - let old_fixpoint_exprl = - List.map - (function - | (name,Some (Struct id),args,types,body),_ -> - let annot = - try Some (dummy_loc, id), Topconstr.CStructRec - with Not_found -> - raise (UserError("",str "Cannot find argument " ++ - Ppconstr.pr_id id)) - in - (name,annot,args,types,body),(None:Vernacexpr.decl_notation) - | (name,None,args,types,body),recdef -> - let names = (Topconstr.names_of_local_assums args) in - if is_one_rec recdef && List.length names > 1 then - user_err_loc - (dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified in Function") - else - let loc, na = List.hd names in - (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body), - (None:Vernacexpr.decl_notation) - | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> - error - ("Cannot use mutual definition with well-founded recursion or measure") - ) - (List.combine fixpoint_exprl recdefs) - in - (* ok all the expressions are structural *) - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl - in - let is_rec = List.exists (is_rec fix_names) recdefs in - if register_built then register_struct is_rec old_fixpoint_exprl; - generate_principle - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct interactive_proof); - if register_built then derive_inversion fix_names; - true; - in - () - -open Topconstr -let rec add_args id new_args b = - match b with - | CRef r -> - begin match r with - | Libnames.Ident(loc,fname) when fname = id -> - CAppExpl(dummy_loc,(None,r),new_args) - | _ -> b - end - | CFix _ | CCoFix _ -> anomaly "add_args : todo" - | CArrow(loc,b1,b2) -> - CArrow(loc,add_args id new_args b1, add_args id new_args b2) - | CProdN(loc,nal,b1) -> - CProdN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, - add_args id new_args b1) - | CLambdaN(loc,nal,b1) -> - CLambdaN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, - add_args id new_args b1) - | CLetIn(loc,na,b1,b2) -> - CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> - begin - match r with - | Libnames.Ident(loc,fname) when fname = id -> - CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) - | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) - end - | CApp(loc,(pf,b),bl) -> - CApp(loc,(pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(loc,sty,b_option,cel,cal) -> - CCases(loc,sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> - add_args id new_args b, - (na,Option.map (add_args id new_args) b_option)) cel, - List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal - ) - | CLetTuple(loc,nal,(na,b_option),b1,b2) -> - CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(loc,b1,(na,b_option),b2,b3) -> - CIf(loc,add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ -> b - | CPatVar _ -> b - | CEvar _ -> b - | CSort _ -> b - | CCast(loc,b1,CastConv(ck,b2)) -> - CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) - | CCast(loc,b1,CastCoerce) -> - CCast(loc,add_args id new_args b1,CastCoerce) - | CRecord _ -> anomaly "add_args : CRecord" - | CNotation _ -> anomaly "add_args : CNotation" - | CGeneralization _ -> anomaly "add_args : CGeneralization" - | CPrim _ -> b - | CDelimiters _ -> anomaly "add_args : CDelimiters" - | CDynamic _ -> anomaly "add_args : CDynamic" -exception Stop of Topconstr.constr_expr - - -(* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Topconstr.constr_expr -*) -let rec chop_n_arrow n t = - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) - match t with - | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) - chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | (nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = - Topconstr.CProdN(dummy_loc, - ((snd (list_chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - in - aux n nal_ta' - in - chop_n_arrow new_n t' - with Stop t -> t - end - | _ -> anomaly "Not enough products" - - -let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = - match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> - begin - let n = - (List.fold_left (fun n (nal,_,_) -> - n+List.length nal) 0 nal_ta ) - in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,k,ta) -> - (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' - end - | _ -> [],b,t - - -let make_graph (f_ref:global_reference) = - let c,c_body = - match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) - end - | _ -> raise (UserError ("", str "Not a function reference") ) - - in - match c_body.const_body with - | None -> error "Cannot build a graph over an axiom !" - | Some b -> - let env = Global.env () in - let body = (force b) in - let extern_body,extern_type = - with_full_print - (fun () -> - (Constrextern.extern_constr false env body, - Constrextern.extern_type false env - (Typeops.type_of_constant_type env c_body.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let loc, rec_id = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> - List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) - nal - ) - nal_tas - ) - in - let b' = add_args (snd id) new_args b in - (id, Some (Struct rec_id),nal_tas@bl,t,b') - ) - fixexprl - in - l - | _ -> - let id = id_of_label (con_label c) in - [((dummy_loc,id),None,nal_tas,t,b)] - in - do_generate_principle error_error false false expr_list; - (* We register the infos *) - let mp,dp,_ = repr_con c in - List.iter - (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) - expr_list - - -(* let make_graph _ = assert false *) - -let do_generate_principle = do_generate_principle warning_error true - - diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml deleted file mode 100644 index a3c169b7..00000000 --- a/contrib/funind/indfun_common.ml +++ /dev/null @@ -1,512 +0,0 @@ -open Names -open Pp - -open Libnames - -let mk_prefix pre id = id_of_string (pre^(string_of_id id)) -let mk_rel_id = mk_prefix "R_" -let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" -let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" -let mk_equation_id id = Nameops.add_suffix id "_equation" - -let msgnl m = - () - -let invalid_argument s = raise (Invalid_argument s) - - -let fresh_id avoid s = Termops.next_global_ident_away true (id_of_string s) avoid - -let fresh_name avoid s = Name (fresh_id avoid s) - -let get_name avoid ?(default="H") = function - | Anonymous -> fresh_name avoid default - | Name n -> Name n - -let array_get_start a = - try - Array.init - (Array.length a - 1) - (fun i -> a.(i)) - with Invalid_argument "index out of bounds" -> - invalid_argument "array_get_start" - -let id_of_name = function - Name id -> id - | _ -> raise Not_found - -let locate ref = - let (loc,qid) = qualid_of_reference ref in - Nametab.locate qid - -let locate_ind ref = - match locate ref with - | IndRef x -> x - | _ -> raise Not_found - -let locate_constant ref = - match locate ref with - | ConstRef x -> x - | _ -> raise Not_found - - -let locate_with_msg msg f x = - try - f x - with - | Not_found -> raise (Util.UserError("", msg)) - | e -> raise e - - -let filter_map filter f = - let rec it = function - | [] -> [] - | e::l -> - if filter e - then - (f e) :: it l - else it l - in - it - - -let chop_rlambda_n = - let rec chop_lambda_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match rt with - | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b - | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b - | _ -> - raise (Util.UserError("chop_rlambda_n", - str "chop_rlambda_n: Not enough Lambdas")) - in - chop_lambda_n [] - -let chop_rprod_n = - let rec chop_prod_n acc n rt = - if n == 0 - then List.rev acc,rt - else - match rt with - | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) - in - chop_prod_n [] - - - -let list_union_eq eq_fun l1 l2 = - let rec urec = function - | [] -> l2 - | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l - in - urec l1 - -let list_add_set_eq eq_fun x l = - if List.exists (eq_fun x) l then l else x::l - - - - -let const_of_id id = - let _,princ_ref = - qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) - in - try Nametab.locate_constant princ_ref - with Not_found -> Util.error ("cannot find "^ string_of_id id) - -let def_of_const t = - match (Term.kind_of_term t) with - Term.Const sp -> - (try (match (Global.lookup_constant sp) with - {Declarations.const_body=Some c} -> Declarations.force c - |_ -> assert false) - with _ -> assert false) - |_ -> assert false - -let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ Coqlib.arith_modules) s;; - -let constant sl s = - constr_of_global - (Nametab.locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; - -let find_reference sl s = - (Nametab.locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; - -let eq = lazy(coq_constant "eq") -let refl_equal = lazy(coq_constant "refl_equal") - -(*****************************************************************) -(* Copy of the standart save mechanism but without the much too *) -(* slow reduction function *) -(*****************************************************************) -open Declarations -open Entries -open Decl_kinds -open Declare -let definition_message id = - Flags.if_verbose message ((string_of_id id) ^ " is defined") - - -let save with_clean id const (locality,kind) hook = - let {const_entry_body = pft; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in - let l,r = match locality with - | Local when Lib.sections_are_opened () -> - let k = logical_kind_of_goal_kind kind in - let c = SectionLocalDef (pft, tpo, opacity) in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Local -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) - | Global -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) in - if with_clean then Pfedit.delete_current_proof (); - hook l r; - definition_message id - - - - -let extract_pftreestate pts = - let pfterm,subgoals = Refiner.extract_open_pftreestate pts in - let tpfsigma = Refiner.evc_of_pftreestate pts in - let exl = Evarutil.non_instantiated tpfsigma in - if subgoals <> [] or exl <> [] then - Util.errorlabstrm "extract_proof" - (if subgoals <> [] then - str "Attempt to save an incomplete proof" - else - str "Attempt to save a proof with existential variables still non-instantiated"); - let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in - env,tpfsigma,pfterm - - -let nf_betaiotazeta = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta - -let nf_betaiota = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiota - -let cook_proof do_reduce = - let pfs = Pfedit.get_pftreestate () -(* and ident = Pfedit.get_current_proof_name () *) - and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in - let env,sigma,pfterm = extract_pftreestate pfs in - let pfterm = - if do_reduce - then nf_betaiota env sigma pfterm - else pfterm - in - (ident, - ({ const_entry_body = pfterm; - const_entry_type = Some concl; - const_entry_opaque = false; - const_entry_boxed = false}, - strength, hook)) - - -let new_save_named opacity = - let id,(const,persistence,hook) = cook_proof true in - let const = { const with const_entry_opaque = opacity } in - save true id const persistence hook - -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in - Pfedit.delete_current_proof (); - result - -let with_full_print f a = - let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in - let old_rawprint = !Flags.raw_print in - Flags.raw_print := true; - Impargs.make_implicit_args false; - Impargs.make_strict_implicit_args false; - Impargs.make_contextual_implicit_args false; - Impargs.make_contextual_implicit_args false; - Dumpglob.pause (); - try - let res = f a in - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Dumpglob.continue (); - res - with - | e -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Flags.raw_print := old_rawprint; - Dumpglob.continue (); - raise e - - - - - - -(**********************) - -type function_info = - { - function_constant : constant; - graph_ind : inductive; - equation_lemma : constant option; - correctness_lemma : constant option; - completeness_lemma : constant option; - rect_lemma : constant option; - rec_lemma : constant option; - prop_lemma : constant option; - is_general : bool; (* Has this function been defined using general recursive definition *) - } - - -(* type function_db = function_info list *) - -(* let function_table = ref ([] : function_db) *) - - -let from_function = ref Cmap.empty -let from_graph = ref Indmap.empty -(* -let rec do_cache_info finfo = function - | [] -> raise Not_found - | (finfo'::finfos as l) -> - if finfo' == finfo then l - else if finfo'.function_constant = finfo.function_constant - then finfo::finfos - else - let res = do_cache_info finfo finfos in - if res == finfos then l else finfo'::l - - -let cache_Function (_,(finfos)) = - let new_tbl = - try do_cache_info finfos !function_table - with Not_found -> finfos::!function_table - in - if new_tbl != !function_table - then function_table := new_tbl -*) - -let cache_Function (_,finfos) = - from_function := Cmap.add finfos.function_constant finfos !from_function; - from_graph := Indmap.add finfos.graph_ind finfos !from_graph - - -let load_Function _ = cache_Function -let open_Function _ = cache_Function -let subst_Function (_,subst,finfos) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) - and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i) - in - let function_constant' = do_subst_con finfos.function_constant in - let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in - let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then finfos - else - { function_constant = function_constant'; - graph_ind = graph_ind'; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma' ; - rect_lemma = rect_lemma' ; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma'; - is_general = finfos.is_general - } - -let classify_Function (_,infos) = Libobject.Substitute infos - -let export_Function infos = Some infos - - -let discharge_Function (_,finfos) = - let function_constant' = Lib.discharge_con finfos.function_constant - and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma - in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && - equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then Some finfos - else - Some { function_constant = function_constant' ; - graph_ind = graph_ind' ; - equation_lemma = equation_lemma' ; - correctness_lemma = correctness_lemma' ; - completeness_lemma = completeness_lemma'; - rect_lemma = rect_lemma'; - rec_lemma = rec_lemma'; - prop_lemma = prop_lemma' ; - is_general = finfos.is_general - } - -open Term -let pr_info f_info = - str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ - (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ - str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ - str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ - str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ - str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ - str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () - -let pr_table tb = - let l = Cmap.fold (fun k v acc -> v::acc) tb [] in - Util.prlist_with_sep fnl pr_info l - -let in_Function,out_Function = - Libobject.declare_object - {(Libobject.default_object "FUNCTIONS_DB") with - Libobject.cache_function = cache_Function; - Libobject.load_function = load_Function; - Libobject.classify_function = classify_Function; - Libobject.subst_function = subst_Function; - Libobject.export_function = export_Function; - Libobject.discharge_function = discharge_Function -(* Libobject.open_function = open_Function; *) - } - - - -(* Synchronisation with reset *) -let freeze () = - !from_function,!from_graph -let unfreeze (functions,graphs) = -(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) - from_function := functions; - from_graph := graphs - -let init () = -(* Pp.msgnl (str "reseting function_table"); *) - from_function := Cmap.empty; - from_graph := Indmap.empty - -let _ = - Summary.declare_summary "functions_db_sum" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } - -let find_or_none id = - try Some - (match Nametab.locate (make_short_qualid id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" - ) - with Not_found -> None - - - -let find_Function_infos f = - Cmap.find f !from_function - - -let find_Function_of_graph ind = - Indmap.find ind !from_graph - -let update_Function finfo = -(* Pp.msgnl (pr_info finfo); *) - Lib.add_anonymous_leaf (in_Function finfo) - - -let add_Function is_general f = - let f_id = id_of_label (con_label f) in - let equation_lemma = find_or_none (mk_equation_id f_id) - and correctness_lemma = find_or_none (mk_correct_id f_id) - and completeness_lemma = find_or_none (mk_complete_id f_id) - and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") - and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") - and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") - and graph_ind = - match Nametab.locate (make_short_qualid (mk_rel_id f_id)) - with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" - in - let finfos = - { function_constant = f; - equation_lemma = equation_lemma; - completeness_lemma = completeness_lemma; - correctness_lemma = correctness_lemma; - rect_lemma = rect_lemma; - rec_lemma = rec_lemma; - prop_lemma = prop_lemma; - graph_ind = graph_ind; - is_general = is_general - - } - in - update_Function finfos - -let pr_table () = pr_table !from_function -(*********************************) -(* Debuging *) -let function_debug = ref false -open Goptions - -let function_debug_sig = - { - optsync = false; - optname = "Function debug"; - optkey = PrimaryTable("Function_debug"); - optread = (fun () -> !function_debug); - optwrite = (fun b -> function_debug := b) - } - -let _ = declare_bool_option function_debug_sig - - -let do_observe () = - !function_debug = true - - - -exception Building_graph of exn -exception Defining_principle of exn diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli deleted file mode 100644 index 7da1d6f0..00000000 --- a/contrib/funind/indfun_common.mli +++ /dev/null @@ -1,117 +0,0 @@ -open Names -open Pp - -(* - The mk_?_id function build different name w.r.t. a function - Each of their use is justified in the code -*) -val mk_rel_id : identifier -> identifier -val mk_correct_id : identifier -> identifier -val mk_complete_id : identifier -> identifier -val mk_equation_id : identifier -> identifier - - -val msgnl : std_ppcmds -> unit - -val invalid_argument : string -> 'a - -val fresh_id : identifier list -> string -> identifier -val fresh_name : identifier list -> string -> name -val get_name : identifier list -> ?default:string -> name -> name - -val array_get_start : 'a array -> 'a array - -val id_of_name : name -> identifier - -val locate_ind : Libnames.reference -> inductive -val locate_constant : Libnames.reference -> constant -val locate_with_msg : - Pp.std_ppcmds -> (Libnames.reference -> 'a) -> - Libnames.reference -> 'a - -val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list -val list_union_eq : - ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list -val list_add_set_eq : - ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list - -val chop_rlambda_n : int -> Rawterm.rawconstr -> - (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr - -val chop_rprod_n : int -> Rawterm.rawconstr -> - (name*Rawterm.rawconstr) list * Rawterm.rawconstr - -val def_of_const : Term.constr -> Term.constr -val eq : Term.constr Lazy.t -val refl_equal : Term.constr Lazy.t -val const_of_id: identifier -> constant - - -(* [save_named] is a copy of [Command.save_named] but uses - [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] - - - - DON'T USE IT if you cannot ensure that there is no VMcast in the proof - -*) - -(* val nf_betaiotazeta : Reductionops.reduction_function *) - -val new_save_named : bool -> unit - -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> - Tacexpr.declaration_hook -> unit - -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof -*) -val get_proof_clean : bool -> - Names.identifier * - (Entries.definition_entry * Decl_kinds.goal_kind * - Tacexpr.declaration_hook) - - - -(* [with_full_print f a] applies [f] to [a] in full printing environment - - This function preserves the print settings -*) -val with_full_print : ('a -> 'b) -> 'a -> 'b - - -(*****************) - -type function_info = - { - function_constant : constant; - graph_ind : inductive; - equation_lemma : constant option; - correctness_lemma : constant option; - completeness_lemma : constant option; - rect_lemma : constant option; - rec_lemma : constant option; - prop_lemma : constant option; - is_general : bool; - } - -val find_Function_infos : constant -> function_info -val find_Function_of_graph : inductive -> function_info -(* WARNING: To be used just after the graph definition !!! *) -val add_Function : bool -> constant -> unit - -val update_Function : function_info -> unit - - -(** debugging *) -val pr_info : function_info -> Pp.std_ppcmds -val pr_table : unit -> Pp.std_ppcmds - - -(* val function_debug : bool ref *) -val do_observe : unit -> bool - -(* To localize pb *) -exception Building_graph of exn -exception Defining_principle of exn - diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml deleted file mode 100644 index 5c8f0871..00000000 --- a/contrib/funind/invfun.ml +++ /dev/null @@ -1,1022 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -open Tacexpr -open Declarations -open Util -open Names -open Term -open Pp -open Libnames -open Tacticals -open Tactics -open Indfun_common -open Tacmach -open Termops -open Sign -open Hiddentac - -(* Some pretty printing function for debugging purpose *) - -let pr_binding prc = - function - | loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) - -let pr_bindings prc prlc = function - | Rawterm.ImplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun (_,c) -> prc c) l - | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ - Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Rawterm.NoBindings -> mt () - - -let pr_with_bindings prc prlc (c,bl) = - prc c ++ hv 0 (pr_bindings prc prlc bl) - - - -let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = - pr_with_bindings prc prc (c,bl) - -(* The local debuging mechanism *) -let msgnl = Pp.msgnl - -let observe strm = - if do_observe () - then Pp.msgnl strm - else () - -let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end - else () - - -let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - try - let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with e -> - msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; - - -let observe_tac s tac g = - if do_observe () - then do_observe_tac (str s) tac g - else tac g - -(* [nf_zeta] $\zeta$-normalization of a term *) -let nf_zeta = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - Environ.empty_env - Evd.empty - - -(* [id_to_constr id] finds the term associated to [id] in the global environment *) -let id_to_constr id = - try - Tacinterp.constr_of_id (Global.env ()) id - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) - -(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] - (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. - - [generate_type true f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion - - [generate_type false f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion - *) - -let generate_type g_to_f f graph i = - (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in - let ctxt,_ = decompose_prod_assum graph_arity in - let fun_ctxt,res_type = - match ctxt with - | [] | [_] -> anomaly "Not a valid context" - | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type - in - let nb_args = List.length fun_ctxt in - let args_from_decl i decl = - match decl with - | (_,Some _,_) -> incr i; failwith "args_from_decl" - | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) - in - (*i We need to name the vars [res] and [fv] i*) - let res_id = - Termops.next_global_ident_away - true - (id_of_string "res") - (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) - in - let fv_id = - Termops.next_global_ident_away - true - (id_of_string "fv") - (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) - in - (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = - let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) - in - let args_as_rels = Array.map Termops.pop args_as_rels in - (*i - the hypothesis [res = fv] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let res_eq_f_of_args = - mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) - in - (*i - The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let graph_applied = - let args_and_res_as_rels = - let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) - in - let args_and_res_as_rels = - Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels - in - mkApp(graph,args_and_res_as_rels) - in - (*i The [pre_context] is the defined to be the context corresponding to - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] - i*) - let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt - in - (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) - else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) - - -(* - [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] - - WARNING: while convertible, [type_of body] and [type] can be non equal -*) -let find_induction_principle f = - let f_as_constant = match kind_of_term f with - | Const c' -> c' - | _ -> error "Must be used with a function" - in - let infos = find_Function_infos f_as_constant in - match infos.rect_lemma with - | None -> raise Not_found - | Some rect_lemma -> - let rect_lemma = mkConst rect_lemma in - let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in - rect_lemma,typ - - - -(* let fname = *) -(* match kind_of_term f with *) -(* | Const c' -> *) -(* id_of_label (con_label c') *) -(* | _ -> error "Must be used with a function" *) -(* in *) - -(* let princ_name = *) -(* ( *) -(* Indrec.make_elimination_ident *) -(* fname *) -(* InType *) -(* ) *) -(* in *) -(* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *) -(* c,Typing.type_of (Global.env ()) Evd.empty c *) - - -let rec generate_fresh_id x avoid i = - if i == 0 - then [] - else - let id = Termops.next_global_ident_away true x avoid in - id::(generate_fresh_id x (id::avoid) (pred i)) - - -(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] - is the tactic used to prove correctness lemma. - - [functional_induction] is the tactic defined in [indfun] (dependency problem) - [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. graphs of the functions and principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove correct - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $x_n$ - \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) - \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the - apply the corresponding constructor of the corresponding graph inductive. - \end{enumerate} - -*) -let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = - fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle - that is~: - \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] - *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> - match ctxt with - | [] | [_] | [_;_] -> anomaly "bad context" - | hres::res::(x,_,t)::ctxt -> - Termops.it_mkLambda_or_LetIn - ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res]) - ((x,None,t)::ctxt) - ) - lemmas_types_infos - in - (* we the get the definition of the graphs block *) - let graph_ind = destInd graphs_constr.(i) in - let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in - (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in - let princ_type = nf_zeta princ_type in - let princ_infos = Tactics.compute_elim_sig princ_type in - (* The number of args of the function is then easilly computable *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in - (* Since we cannot ensure that the funcitonnal principle is defined in the - environement and due to the bug #1174, we will need to pose the principle - using a name - *) - let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun (_,_,br_type) -> - List.map - (fun id -> dummy_loc, Genarg.IntroIdentifier id) - (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) - ) - branches - in - (* before building the full intro pattern for the principle *) - let pat = Some (dummy_loc,Genarg.IntroOrAndPattern intro_pats) in - let eq_ind = Coqlib.build_coq_eq () in - let eq_construct = mkConstruct((destInd eq_ind),1) in - (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in - (* The tactic to prove the ith branch of the principle *) - let prove_branche i g = - (* We get the identifiers of this branch *) - let this_branche_ids = - List.fold_right - (fun (_,pat) acc -> - match pat with - | Genarg.IntroIdentifier id -> Idset.add id acc - | _ -> anomaly "Not an identifier" - ) - (List.nth intro_pats (pred i)) - Idset.empty - in - (* and get the real args of the branch by unfolding the defined constant *) - let pre_args,pre_tac = - List.fold_right - (fun (id,b,t) (pre_args,pre_tac) -> - if Idset.mem id this_branche_ids - then - match b with - | None -> (id::pre_args,pre_tac) - | Some b -> - (pre_args, - tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac - ) - - else (pre_args,pre_tac) - ) - (pf_hyps g) - ([],tclIDTAC) - in - (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type - $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - - If [hid] has another type the corresponding argument of the constructor is [hid] - *) - let constructor_args = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_type_of g (mkVar hid) in - match kind_of_term type_of_hid with - | Prod(_,_,t') -> - begin - match kind_of_term t' with - | Prod(_,t'',t''') -> - begin - match kind_of_term t'',kind_of_term t''' with - | App(eq,args), App(graph',_) - when - (eq_constr eq eq_ind) && - array_exists (eq_constr graph') graphs_constr -> - ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::args.(2)::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args = - let params_id = fst (list_chop princ_infos.nparams args_names) in - (List.map mkVar params_id)@(List.rev constructor_args) - in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number - *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end - in - (* we can then build the final proof term *) - let app_constructor = applist((mkConstruct(constructor)),constructor_args) in - (* an apply the tactic *) - let res,hres = - match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres - | _ -> assert false - in - observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); - ( - tclTHENSEQ - [ - (* unfolding of all the defined variables introduced by this branch *) - observe_tac "unfolding" pre_tac; - (* $zeta$ normalizing of the conclusion *) - h_reduce - (Rawterm.Cbv - { Rawterm.all_flags with - Rawterm.rDelta = false ; - Rawterm.rConst = [] - } - ) - onConcl; - (* introducing the the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP h_intro [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); - (* Conclusion *) - observe_tac "exact" (h_exact app_constructor) - ] - ) - g - in - (* end of branche proof *) - let param_names = fst (list_chop princ_infos.nparams args_names) in - let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in - (* The bindings of the principle - that is the params of the principle and the different lemma types - *) - let bindings = - let params_bindings,avoid = - List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Nameops.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,inj_open p)::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) - in - let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Nameops.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) - in - Rawterm.ExplicitBindings (params_bindings@lemmas_bindings) - in - tclTHENSEQ - [ observe_tac "intro args_names" (tclMAP h_intro args_names); - observe_tac "principle" (assert_by - (Name principle_id) - princ_type - (h_exact f_principle)); - tclTHEN_i - (observe_tac "functional_induction" ( - fun g -> - observe - (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); - functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) - (Some (mkVar principle_id,bindings)) - pat g - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] - g - -(* [generalize_dependent_of x hyp g] - generalize every hypothesis which depends of [x] but [hyp] -*) -let generalize_dependent_of x hyp g = - tclMAP - (function - | (id,None,t) when not (id = hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g - - - - - - (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis - (unfolding, substituting, destructing cases \ldots) - *) -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : tactic = - fun g -> - let eq_ind = Coqlib.build_coq_eq () in - match kind_of_term (pf_concl g) with - | Prod(_,t,t') -> - begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g - - else if isVar args.(1) - then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; - generalize_dependent_of (destVar args.(1)) id; - tclTRY (Equality.rewriteLR (mkVar id)); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ[ - h_intro id; - tclTRY (Equality.rewriteLR (mkVar id)); - intros_with_rewrite - ] g - end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> - Tauto.tauto g - | Case(_,_,v,_) -> - tclTHENSEQ[ - h_case false (v,Rawterm.NoBindings); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENSEQ[ - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - onConcl - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id;intros_with_rewrite] g - end - | LetIn _ -> - tclTHENSEQ[ - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - onConcl - ; - intros_with_rewrite - ] g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = - let destruct_case () = - try - match kind_of_term (snd (destApp (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENSEQ[ - h_case false (v,Rawterm.NoBindings); - intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] - | _ -> reflexivity - with _ -> reflexivity - in - let eq_ind = Coqlib.build_coq_eq () in - let discr_inject = - Tacticals.onAllClauses ( - fun sc g -> - match sc with - None -> tclIDTAC g - | Some ((_,id),_) -> - match kind_of_term (pf_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Equality.discrHyp id g - else if Equality.injectable (pf_env g) (project g) t1 t2 - then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g - else tclIDTAC g - | _ -> tclIDTAC g - ) - in - (tclFIRST - [ reflexivity; - tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing - *) - tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases - ]) - g - - -(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completness lemma. - - [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove complete - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $H:graph\ x_1\ldots x_n\ res$ - \item $elim\ H$ using schemes.(i) - \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has - type [x=?] with [x] a variable, then subst [x], - if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else - if [h] is a match then destruct it, else do just introduce it, - after all intros, the conclusion should be a reflexive equality. - \end{enumerate} - -*) - - -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) - lemmas_types_infos - in - (* We get the constant and the principle corresponding to this lemma *) - let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in - let princ_type = pf_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig princ_type in - (* Then we get the number of argument of the function - and compute a fresh name for each of them - *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in - let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = - match generate_fresh_id (id_of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false - in - let ids = res::hres::graph_principle_id::ids in - (* we also compute fresh names for each hyptohesis of each branche of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun (_,_,br_type) -> - List.map - (fun id -> id) - (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) - ) - branches - in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite - *) - let rewrite_tac j ids : tactic = - let graph_def = graphs.(j) in - let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in - if infos.is_general || Rtree.is_infinite graph_def.mind_recargs - then - let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly "Cannot find equation lemma" - in - tclTHENSEQ[ - tclMAP h_intro ids; - Equality.rewriteLR (mkConst eq_lemma); - (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - onConcl - ; - h_generalize (List.map mkVar ids); - thin ids - ] - else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end - in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENSEQ[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] - g - in - let params_names = fst (list_chop princ_infos.nparams args_names) in - let params = List.map mkVar params_names in - tclTHENSEQ - [ tclMAP h_intro (args_names@[res;hres]); - observe_tac "h_generalize" - (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); - h_intro graph_principle_id; - observe_tac "" (tclTHEN_i - (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] - g - - - - -let do_save () = Command.save_named false - - -(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness - lemmas for each function in [funs] w.r.t. [graphs] - - [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and - [functional_induction] is Indfun.functional_induction (same pb) -*) - -let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = - let funs = Array.of_list funs and graphs = Array.of_list graphs in - let funs_constr = Array.map mkConst funs in - try - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = - generate_type false const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if Array.length funs_constr <> 1 then raise Not_found; - [| find_induction_principle funs_constr.(0) |] - with Not_found -> - Array.of_list - (List.map - (fun entry -> - (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) - ) - (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) - ) - in - let proving_tac = - prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - (mk_correct_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) - (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); - do_save (); - let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) - } - - ) - funs; - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = - generate_type true const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let kn,_ as graph_ind = destInd graphs_constr.(0) in - let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list - (Indrec.build_mutual_indrec (Global.env ()) Evd.empty - (Array.to_list - (Array.mapi - (fun i mip -> (kn,i),mib,mip,true,InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - (mk_complete_id f_id) - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - (fst lemmas_types_infos.(i)) - (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); - do_save (); - let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) - } - ) - funs; - with e -> - (* In case of problem, we reset all the lemmas *) - (*i The next call to mk_correct_id is valid since we are erasing the lemmas - Ensures by: obvious - i*) - let first_lemma_id = - let f_id = id_of_label (con_label funs.(0)) in - - mk_correct_id f_id - in - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); - raise e - - - - - -(***********************************************) - -(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res - when [kn] denotes a graph block into - f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result - - if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing -*) -let revert_graph kn post_tac hid g = - let typ = pf_type_of g (mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in - if kn = kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = - try find_Function_of_graph ind' - with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly "Cannot retrieve infos about a mutual block" - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC g - | Some f_complete -> - let f_args,res = array_chop (Array.length args - 1) args in - tclTHENSEQ - [ - h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; - thin [hid]; - h_intro hid; - post_tac hid - ] - g - - else tclIDTAC g - | _ -> tclIDTAC g - - -(* - [functional_inversion hid fconst f_correct ] is the functional version of [inversion] - - [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] - is the correctness lemma for [fconst]. - - The sketch is the follwing~: - \begin{enumerate} - \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ - (fails if it is not possible) - \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] - \item apply [inversion] on [hid] - \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever - such a lemma exists) - \end{enumerate} -*) - -let functional_inversion kn hid fconst f_correct : tactic = - fun g -> - let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in - let type_of_h = pf_type_of g (mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> - let pre_tac,f_args,res = - match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when eq_constr f fconst -> - ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in - tclTHENSEQ[ - pre_tac hid; - h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; - thin [hid]; - h_intro hid; - Inv.inv FullInversion None (Rawterm.NamedHyp hid); - (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) g - ); - ] g - | _ -> tclFAIL 1 (mt ()) g - - - -let invfun qhyp f = - let f = - match f with - | ConstRef f -> f - | _ -> raise (Util.UserError("",str "Not a function")) - in - try - let finfos = find_Function_infos f in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp - with - | Not_found -> error "No graph found" - | Option.IsNone -> error "Cannot use equivalence with graph!" - - -let invfun qhyp f g = - match f with - | Some f -> invfun qhyp f g - | None -> - Tactics.try_intros_until - (fun hid g -> - let hyp_typ = pf_type_of g (mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> - begin - let f1,_ = decompose_app args.(1) in - try - if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct g - with | Failure "" | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app args.(2) in - if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct g - with - | Failure "" -> - errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") - | Option.IsNone -> - if do_observe () - then - error "Cannot use equivalence with graph for any side of the equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () - then - error "No graph found for any side of equality" - else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - end - | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") - ) - qhyp - g diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml deleted file mode 100644 index 9bbd165d..00000000 --- a/contrib/funind/merge.ml +++ /dev/null @@ -1,1034 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Merging of induction principles. *) - -(*i $Id: i*) -open Libnames -open Tactics -open Indfun_common -open Util -open Topconstr -open Vernacexpr -open Pp -open Names -open Term -open Termops -open Declarations -open Environ -open Rawterm -open Rawtermops - -(** {1 Utilities} *) - -(** {2 Useful operations on constr and rawconstr} *) - -let rec popn i c = if i<=0 then c else pop (popn (i-1) c) - -(** Substitutions in constr *) -let compare_constr_nosub t1 t2 = - if compare_constr (fun _ _ -> false) t1 t2 - then true - else false - -let rec compare_constr' t1 t2 = - if compare_constr_nosub t1 t2 - then true - else (compare_constr (compare_constr') t1 t2) - -let rec substitterm prof t by_t in_u = - if (compare_constr' (lift prof t) in_u) - then (lift prof by_t) - else map_constr_with_binders succ - (fun i -> substitterm i t by_t) prof in_u - -let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl - -let understand = Pretyping.Default.understand Evd.empty (Global.env()) - -(** Operations on names and identifiers *) -let id_of_name = function - Anonymous -> id_of_string "H" - | Name id -> id;; -let name_of_string str = Name (id_of_string str) -let string_of_name nme = string_of_id (id_of_name nme) - -(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) -let isVarf f x = - match x with - | RVar (_,x) -> Pervasives.compare x f = 0 - | _ -> false - -(** [ident_global_exist id] returns true if identifier [id] is linked - in global environment. *) -let ident_global_exist id = - try - let ans = CRef (Libnames.Ident (dummy_loc,id)) in - let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in - true - with _ -> false - -(** [next_ident_fresh id] returns a fresh identifier (ie not linked in - global env) with base [id]. *) -let next_ident_fresh (id:identifier) = - let res = ref id in - while ident_global_exist !res do res := Nameops.lift_ident !res done; - !res - - -(** {2 Debugging} *) -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" -(* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c) -let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); - msg(str ""); - end -let prNamedRConstr s c = - begin - msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); - msg(str ""); - end -let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc -let prNamedLConstr s lc = - begin - prstr "[§§§ "; - prstr s; - prNamedLConstr_aux lc; - prstr " §§§]\n"; - end -let prNamedLDecl s lc = - begin - prstr s; prstr "\n"; - List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; - prstr "\n"; - end -let prNamedRLDecl s lc = - begin - prstr s; prstr "\n"; prstr "{§§ "; - List.iter - (fun x -> - match x with - | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp - | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy - | _ -> assert false - ) lc; - prstr " §§}\n"; - prstr "\n"; - end - -let showind (id:identifier) = - let cstrid = Tacinterp.constr_of_id (Global.env()) id in - let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in - List.iter (fun (nm, optcstr, tp) -> - print_string (string_of_name nm^":"); - prconstr tp; print_string "\n") - ib1.mind_arity_ctxt; - (match ib1.mind_arity with - | Monomorphic x -> - Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> - Printf.printf "arity : universe?"); - Array.iteri - (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) - ib1.mind_user_lc - -(** {2 Misc} *) - -exception Found of int - -(* Array scanning *) -let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = - try - for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; - None - with Found i -> Some i - -let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = - try - for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; - Array.length arr (* all elt are positive *) - with Found i -> i - -let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = - let i = ref 0 in - Array.fold_left - (fun acc x -> - let res = f !i acc x in i := !i + 1; res) - acc arr - -(* Like list_chop but except that [i] is the size of the suffix of [l]. *) -let list_chop_end i l = - let size_prefix = List.length l -i in - if size_prefix < 0 then failwith "list_chop_end" - else list_chop size_prefix l - -let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = - let i = ref 0 in - List.fold_left - (fun acc x -> - let res = f !i acc x in i := !i + 1; res) - acc arr - -let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = - let i = ref 0 in - List.filter (fun x -> let res = f !i x in i := !i + 1; res) l - - -(** Iteration module *) -module For = -struct - let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) - let rec foldup i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc - let rec folddown i j (f: 'a -> int -> 'a) acc = - if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc - let fold i j = if i<j then foldup i j else folddown i j -end - - -(** {1 Parameters shifting and linking information} *) - -(** This type is used to deal with debruijn linked indices. When a - variable is linked to a previous one, we will ignore it and refer - to previous one. *) -type linked_var = - | Linked of int - | Unlinked - | Funres - -(** When merging two graphs, parameters may become regular arguments, - and thus be shifted. This type describes the result of computing - the changes. *) -type 'a shifted_params = - { - nprm1:'a; - nprm2:'a; - prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *) - nuprm1:'a; - nuprm2:'a; - nargs1:'a; - nargs2:'a; - } - - -let prlinked x = - match x with - | Linked i -> Printf.sprintf "Linked %d" i - | Unlinked -> Printf.sprintf "Unlinked" - | Funres -> Printf.sprintf "Funres" - -let linkmonad f lnkvar = - match lnkvar with - | Linked i -> Linked (f i) - | Unlinked -> Unlinked - | Funres -> Funres - -let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar - -(* This map is used to deal with debruijn linked indices. *) -module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) - -let pr_links l = - Printf.printf "links:\n"; - Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; - Printf.printf "_____________\n" - -type 'a merged_arg = - | Prm_stable of 'a - | Prm_linked of 'a - | Prm_arg of 'a - | Arg_stable of 'a - | Arg_linked of 'a - | Arg_funres - -(** Information about graph merging of two inductives. - All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) - -type merge_infos = - { - ident:identifier; (** new inductive name *) - mib1: mutual_inductive_body; - oib1: one_inductive_body; - mib2: mutual_inductive_body; - oib2: one_inductive_body; - - (** Array of links of the first inductive (should be all stable) *) - lnk1: int merged_arg array; - - (** Array of links of the second inductive (point to the first ind param/args) *) - lnk2: int merged_arg array; - - (** rec params which remain rec param (ie not linked) *) - recprms1: rel_declaration list; - recprms2: rel_declaration list; - nrecprms1: int; - nrecprms2: int; - - (** rec parms which became non parm (either linked to something - or because after a rec parm that became non parm) *) - otherprms1: rel_declaration list; - otherprms2: rel_declaration list; - notherprms1:int; - notherprms2:int; - - (** args which remain args in merge *) - args1:rel_declaration list; - args2:rel_declaration list; - nargs1:int; - nargs2:int; - - (** functional result args *) - funresprms1: rel_declaration list; - funresprms2: rel_declaration list; - nfunresprms1:int; - nfunresprms2:int; - } - - -let pr_merginfo x = - let i,s= - match x with - | Prm_linked i -> Some i,"Prm_linked" - | Arg_linked i -> Some i,"Arg_linked" - | Prm_stable i -> Some i,"Prm_stable" - | Prm_arg i -> Some i,"Prm_arg" - | Arg_stable i -> Some i,"Arg_stable" - | Arg_funres -> None , "Arg_funres" in - match i with - | Some i -> Printf.sprintf "%s(%d)" s i - | None -> Printf.sprintf "%s" s - -let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false - -(* ?? prm_linked?? *) -let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false - -let is_stable x = - match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false - -let isArg_funres x = match x with Arg_funres -> true | _ -> false - -let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = - let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in - let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in - let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in - prms@args@fres - -(** Reverse the link map, keeping only linked vars, elements are list - of int as several vars may be linked to the same var. *) -let revlinked lnk = - For.fold 0 (Array.length lnk - 1) - (fun acc k -> - match lnk.(k) with - | Unlinked | Funres -> acc - | Linked i -> - let old = try Link.find i acc with Not_found -> [] in - Link.add i (k::old) acc) - Link.empty - -let array_switch arr i j = - let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux - -let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = - let larr = Array.of_list l in - let _ = - Array.iteri - (fun j x -> - match x with - | Prm_linked i -> array_switch larr i j - | Arg_linked i -> array_switch larr i j - | Prm_stable i -> () - | Prm_arg i -> () - | Arg_stable i -> () - | Arg_funres -> () - ) lnk in - filter_shift_stable lnk (Array.to_list larr) - - - - -(** {1 Utilities for merging} *) - -let ind1name = id_of_string "__ind1" -let ind2name = id_of_string "__ind2" - -(** Performs verifications on two graphs before merging: they must not - be co-inductive, and for the moment they must not be mutual - either. *) -let verify_inds mib1 mib2 = - if not mib1.mind_finite then error "First argument is coinductive"; - if not mib2.mind_finite then error "Second argument is coinductive"; - if mib1.mind_ntypes <> 1 then error "First argument is mutual"; - if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; - () - -(* -(** [build_raw_params prms_decl avoid] returns a list of variables - attributed to the list of decl [prms_decl], avoiding names in - [avoid]. *) -let build_raw_params prms_decl avoid = - let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in - let _ = prNamedConstr "DUMMY" dummy_constr in - let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in - let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in - let res,_ = raw_decompose_prod dummy_rawconstr in - let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) -*) - -let ids_of_rawlist avoid rawl = - List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) - - - -(** {1 Merging function graphs} *) - -(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec - uniform and ordinary ones) of mutual inductives [mib1] and [mib2] - remain uniform when linked by [lnk]. All parameters are - considered, ie we take parameters of the first inductive body of - [mib1] and [mib2]. - - Explanation: The two inductives have parameters, some of the first - are recursively uniform, some of the last are functional result of - the functional graph. - - (I x1 x2 ... xk ... xk' ... xn) - (J y1 y2 ... xl ... yl' ... ym) - - Problem is, if some rec unif params are linked to non rec unif - ones, they become non rec (and the following too). And functinal - argument have to be shifted at the end *) -let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = - let _ = prstr "\nYOUHOU shift\n" in - let linked_targets = revlinked lnk2 in - let is_param_of_mib1 x = x < mib1.mind_nparams_rec in - let is_param_of_mib2 x = x < mib2.mind_nparams_rec in - let is_targetted_by_non_recparam_lnk1 i = - try - let targets = Link.find i linked_targets in - List.exists (fun x -> not (is_param_of_mib2 x)) targets - with Not_found -> false in - let mlnk1 = - Array.mapi - (fun i lkv -> - let isprm = is_param_of_mib1 i in - let prmlost = is_targetted_by_non_recparam_lnk1 i in - match isprm , prmlost, lnk1.(i) with - | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) - | true , false , _-> Prm_stable i (* recparam remains recparam*) - | false , false , Funres -> Arg_funres - | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) - | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) - lnk1 in - let mlnk2 = - Array.mapi - (fun i lkv -> - (* Is this correct if some param of ind2 is lost? *) - let isprm = is_param_of_mib2 i in - match isprm , lnk2.(i) with - | true , Linked j when not (is_param_of_mib1 j) -> - Prm_arg j (* recparam becoming ordinary *) - | true , Linked j -> Prm_linked j (*recparam linked to recparam*) - | true , Unlinked -> Prm_stable i (* recparam remains recparam*) - | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) - | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) - | false , Funres -> Arg_funres - | true , Funres -> assert false (* fun res cannot be a rec param *) - ) - lnk2 in - let oib1 = mib1.mind_packets.(0) in - let oib2 = mib2.mind_packets.(0) in - (* count params remaining params *) - let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in - let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in - let bldprms arity_ctxt mlnk = - list_fold_lefti - (fun i (acc1,acc2,acc3,acc4) x -> - prstr (pr_merginfo mlnk.(i));prstr "\n"; - match mlnk.(i) with - | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 - | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4 - | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4 - | Arg_funres -> acc1 , acc2 , acc3, x::acc4 - | _ -> acc1 , acc2 , acc3, acc4) - ([],[],[],[]) arity_ctxt in -(* let arity_ctxt2 = - build_raw_params oib2.mind_arity_ctxt - (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*) - let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in - let _ = prstr "\n\n\n" in - let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in - let _ = prstr "\notherprms1:\n" in - let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") - otherprms1 in - let _ = prstr "\notherprms2:\n" in - let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") - otherprms2 in - { - ident=id; - mib1=mib1; - oib1 = oib1; - mib2=mib2; - oib2 = oib2; - lnk1 = mlnk1; - lnk2 = mlnk2; - nrecprms1 = n_params1; - recprms1 = recprms1; - otherprms1 = otherprms1; - args1 = args1; - funresprms1 = funresprms1; - notherprms1 = Array.length mlnk1 - n_params1; - nfunresprms1 = List.length funresprms1; - nargs1 = List.length args1; - nrecprms2 = n_params2; - recprms2 = recprms2; - otherprms2 = otherprms2; - args2 = args2; - funresprms2 = funresprms2; - notherprms2 = Array.length mlnk2 - n_params2; - nargs2 = List.length args2; - nfunresprms2 = List.length funresprms2; - } - - - - -(** {1 Merging functions} *) - -exception NoMerge - -let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> - let _ = prstr "\nICI1!\n";Pp.flush_all() in - let args = filter_shift_stable lnk (arr1 @ arr2) in - RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) - | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2!\n";Pp.flush_all() in - let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3!\n";Pp.flush_all() in - let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in - raise NoMerge - -let rec merge_app_unsafe c1 c2 shift filter_shift_stable = - let lnk = Array.append shift.lnk1 shift.lnk2 in - match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) -> - let args = filter_shift_stable lnk (arr1 @ arr2) in - RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) - (* FIXME: what if the function appears in the body of the let? *) - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2 '!\n";Pp.flush_all() in - let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3 '!\n";Pp.flush_all() in - let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge - - - -(* Heuristic when merging two lists of hypothesis: merge every rec - calls of branch 1 with all rec calls of branch 2. *) -(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let rec merge_rec_hyps shift accrec - (ltyp:(Names.name * rawconstr option * rawconstr option) list) - filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list = - let mergeonehyp t reldecl = - match reldecl with - | (nme,x,Some (RApp(_,i,args) as ind)) - -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) - | (nme,Some _,None) -> error "letins with recursive calls not treated yet" - | (nme,None,Some _) -> assert false - | (nme,None,None) | (nme,Some _,Some _) -> assert false in - match ltyp with - | [] -> [] - | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> - let rechyps = List.map (mergeonehyp t) accrec in - rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable - | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable - - -let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = - List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec - - -let find_app (nme:identifier) ltyp = - try - ignore - (List.map - (fun x -> - match x with - | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) - | _ -> ()) - ltyp); - false - with Found _ -> true - -let prnt_prod_or_letin nm letbdy typ = - match letbdy , typ with - | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy - | None , Some tp -> prNamedRConstr (string_of_name nm) tp - | _ , _ -> assert false - - -let rec merge_types shift accrec1 - (ltyp1:(name * rawconstr option * rawconstr option) list) - (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2 - : (name * rawconstr option * rawconstr option) list * rawconstr = - let _ = prstr "MERGE_TYPES\n" in - let _ = prstr "ltyp 1 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in - let _ = prstr "\nltyp 2 : " in - let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in - let _ = prstr "\n" in - let res = - match ltyp1 with - | [] -> - let isrec1 = (accrec1<>[]) in - let isrec2 = find_app ind2name ltyp2 in - let rechyps = - if isrec1 && isrec2 - then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) - merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] - filter_shift_stable - else if isrec1 - (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then - merge_rec_hyps shift accrec1 - (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable - else if isrec2 - then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 - filter_shift_stable_right - else ltyp2 in - let _ = prstr"\nrechyps : " in - let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in - let _ = prstr "MERGE CONCL : " in - let _ = prNamedRConstr "concl1" concl1 in - let _ = prstr " with " in - let _ = prNamedRConstr "concl2" concl2 in - let _ = prstr "\n" in - let concl = - merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in - let _ = prstr "FIN " in - let _ = prNamedRConstr "concl" concl in - let _ = prstr "\n" in - - rechyps , concl - | (nme,None, Some t1)as e ::lt1 -> - (match t1 with - | RApp(_,f,carr) when isVarf ind1name f -> - merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 - | _ -> - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,None,Some t1) :: recres) , recconcl2) - | (nme,Some bd, None) ::lt1 -> - (* FIXME: what if ind1name appears in bd? *) - let recres, recconcl2 = - merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,Some bd,None) :: recres) , recconcl2 - | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false - in - res - - -(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of - linked args [allargs2] to target args of [allargs1] as specified - in [shift]. [allargs1] and [allargs2] are in reverse order. Also - returns the list of unlinked vars of [allargs2]. *) -let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) - (lnk:int merged_arg array) = - array_fold_lefti - (fun i acc e -> - if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) - else - match e with - | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc - | _ -> acc) - Idmap.empty lnk - -let build_link_map allargs1 allargs2 lnk = - let allargs1 = - Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in - let allargs2 = - Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in - build_link_map_aux allargs1 allargs2 lnk - - -(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two - constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and - [typcstr2] contain all parameters (including rec. unif. ones) of - their inductive. - - if [typcstr1] and [typcstr2] are of the form: - - forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) - forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) - - we build: - - forall recparams1 (recparams2 without linked params), - forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... - -> (newI x1 ... z1 x2 y2 ...z2 without linked params) - - where Hix' have been adapted, ie: - - linked vars have been changed, - - rec calls to I1 and I2 have been replaced by rec calls to - newI. More precisely calls to I1 and I2 have been merge by an - experimental heuristic (in particular if n o rec calls for I1 - or I2 is found, we use the conclusion as a rec call). See - [merge_types] above. - - Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. - - TODO: return nothing if equalities (after linking) are contradictory. *) -let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) - (typcstr2:rawconstr) : rawconstr = - (* FIXME: les noms des parametres corerspondent en principe au - parametres du niveau mib, mais il faudrait s'en assurer *) - (* shift.nfunresprmsx last args are functional result *) - let nargs1 = - shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in - let nargs2 = - shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in - let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in - (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) - let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in - let rest2 = change_vars linked_map rest2 in - let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in - let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in - let ltyp,concl2 = - merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in - let _ = prNamedRLDecl "ltyp result:" ltyp in - let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in - let revargs1 = - list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in - let _ = prNamedRLDecl "ltyp allargs1" allargs1 in - let _ = prNamedRLDecl "ltyp revargs1" revargs1 in - let revargs2 = - list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in - let _ = prNamedRLDecl "ltyp allargs2" allargs2 in - let _ = prNamedRLDecl "ltyp revargs2" revargs2 in - let typwithprms = - raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in - typwithprms - - -(** constructor numbering *) -let fresh_cstror_suffix , cstror_suffix_init = - let cstror_num = ref 0 in - (fun () -> - let res = string_of_int !cstror_num in - cstror_num := !cstror_num + 1; - res) , - (fun () -> cstror_num := 0) - -(** [merge_constructor_id id1 id2 shift] returns the identifier of the - new constructor from the id of the two merged constructor and - the merging info. *) -let merge_constructor_id id1 id2 shift:identifier = - let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in - next_ident_fresh (id_of_string id) - - - -(** [merge_constructors lnk shift avoid] merges the two list of - constructor [(name*type)]. These are translated to rawterms - first, each of them having distinct var names. *) -let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * rawconstr) list) - (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = - List.flatten - (List.map - (fun (id1,rawtyp1) -> - List.map - (fun (id2,rawtyp2) -> - let typ = merge_one_constructor shift rawtyp1 rawtyp2 in - let newcstror_id = merge_constructor_id id1 id2 shift in - let _ = prstr "\n**************\n" in - newcstror_id , typ) - typcstr2) - typcstr1) - -(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two - inductive bodies [oib1] and [oib2], linking with [lnk], params - info in [shift], avoiding identifiers in [avoid]. *) -let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) - (oib2:one_inductive_body) = - (* building rawconstr type of constructors *) - let mkrawcor nme avoid typ = - (* first replace rel 1 by a varname *) - let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in - Detyping.detype false (Idset.elements avoid) [] substindtyp in - let lcstr1: rawconstr list = - Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in - (* add to avoid all indentifiers of lcstr1 *) - let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in - let lcstr2 = - Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in - let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in - - let params1 = - try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with _ -> [] in - let params2 = - try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with _ -> [] in - - let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in - let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in - - cstror_suffix_init(); - params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2 - - -(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual - inductive bodies [mib1] and [mib2] linking vars with - [lnk]. [shift] information on parameters of the new inductive. - For the moment, inductives are supposed to be non mutual. -*) -let rec merge_mutual_inductive_body - (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = - (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) - - -let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) - Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x - -let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = - let params = prms2 @ prms1 in - let resparams = - List.fold_left - (fun acc (nme,tp) -> - let _ = prstr "param :" in - let _ = prNamedRConstr (string_of_name nme) tp in - let _ = prstr " ; " in - let typ = rawterm_to_constr_expr tp in - LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) - [] params in - let concl = Constrextern.extern_constr false (Global.env()) concl in - let arity,_ = - List.fold_left - (fun (acc,env) (nm,_,c) -> - let typ = Constrextern.extern_constr false env c in - let newenv = Environ.push_rel (nm,None,c) env in - CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) - (concl,Global.env()) - (shift.funresprms2 @ shift.funresprms1 - @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in - resparams,arity - - - -(** [rawterm_list_to_inductive_expr ident rawlist] returns the - induct_expr corresponding to the the list of constructor types - [rawlist], named ident. - FIXME: params et cstr_expr (arity) *) -let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * rawconstr) list) = - let lident = dummy_loc, shift.ident in - let bindlist , cstr_expr = (* params , arities *) - merge_rec_params_and_arity prms1 prms2 shift mkSet in - let lcstor_expr : (bool * (lident * constr_expr)) list = - List.map (* zeta_normalize t ? *) - (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) - rawlist in - lident , bindlist , Some cstr_expr , lcstor_expr - - - -let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = - match rdecl with - | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - RProd (dummy_loc,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false - - - - -let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = - match rdecl with - | (nme,None,t) -> - let traw = Detyping.detype false [] [] t in - RProd (dummy_loc,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false - - -(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking - variables specified in [lnk]. Graphs are not supposed to be mutual - inductives for the moment. *) -let merge_inductive (ind1: inductive) (ind2: inductive) - (lnk1: linked_var array) (lnk2: linked_var array) id = - let env = Global.env() in - let mib1,_ = Inductive.lookup_mind_specif env ind1 in - let mib2,_ = Inductive.lookup_mind_specif env ind2 in - let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) - (* compute params that become ordinary args (because linked to ord. args) *) - let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in - let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in - let _ = prstr "\nrawlist : " in - let _ = - List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in - let _ = prstr "\nend rawlist\n" in -(* FIX: retransformer en constr ici - let shift_prm = - { shift_prm with - recprms1=prms1; - recprms1=prms1; - } in *) - let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in - (* Declare inductive *) - Command.build_mutual [(indexpr,None)] true (* means: not coinductive *) - - -(* Find infos on identifier id. *) -let find_Function_infos_safe (id:identifier): Indfun_common.function_info = - let kn_of_id x = - let f_ref = Libnames.Ident (dummy_loc,x) in - locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref) - locate_constant f_ref in - try find_Function_infos (kn_of_id id) - with Not_found -> - errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme") - -(** [merge id1 id2 args1 args2 id] builds and declares a new inductive - type called [id], representing the merged graphs of both graphs - [ind1] and [ind2]. identifiers occuring in both arrays [args1] and - [args2] are considered linked (i.e. are the same variable) in the - new graph. - - Warning: For the moment, repetitions of an id in [args1] or - [args2] are not supported. *) -let merge (id1:identifier) (id2:identifier) (args1:identifier array) - (args2:identifier array) id : unit = - let finfo1 = find_Function_infos_safe id1 in - let finfo2 = find_Function_infos_safe id2 in - (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) - (* We add one arg (functional arg of the graph) *) - let lnk1 = Array.make (Array.length args1 + 1) Unlinked in - let lnk2' = (* args2 may be linked to args1 members. FIXME: same - as above: vars may be linked inside args2?? *) - Array.mapi - (fun i c -> - match array_find args1 (fun i x -> x=c) with - | Some j -> Linked j - | None -> Unlinked) - args2 in - (* We add one arg (functional arg of the graph) *) - let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in - (* setting functional results *) - let _ = lnk1.(Array.length lnk1 - 1) <- Funres in - let _ = lnk2.(Array.length lnk2 - 1) <- Funres in - merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id - - -let remove_last_arg c = - let (x,y) = decompose_prod c in - let xnolast = List.rev (List.tl (List.rev x)) in - compose_prod xnolast y - -let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l) -let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l)) - -let remove_last_n_arg n c = - let (x,y) = decompose_prod c in - let xnolast = remove_n_last_list n x in - compose_prod xnolast y - -(* [funify_branches relinfo nfuns branch] returns the branch [branch] - of the relinfo [relinfo] modified to fit in a functional principle. - Things to do: - - remove indargs from rel applications - - replace *variables only* corresponding to function (recursive) - results by the actual function application. *) -let funify_branches relinfo nfuns branch = - let mut_induct, induct = - match relinfo.indref with - | None -> assert false - | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind - | _ -> assert false in - let is_dom c = - match kind_of_term c with - | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct - | _ -> false in - let _dom_i c = - assert (is_dom c); - match kind_of_term c with - | Ind((u,i)) | Construct((u,_),i) -> i - | _ -> assert false in - let _is_pred c shift = - match kind_of_term c with - | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) - | _ -> false in - (* FIXME: *) - (Anonymous,Some mkProp,mkProp) - - -let relprinctype_to_funprinctype relprinctype nfuns = - let relinfo = compute_elim_sig relprinctype in - assert (not relinfo.farg_in_concl); - assert (relinfo.indarg_in_concl); - (* first remove indarg and indarg_in_concl *) - let relinfo_noindarg = { relinfo with - indarg_in_concl = false; indarg = None; - concl = remove_last_arg (pop relinfo.concl); } in - (* the nfuns last induction arguments are functional ones: remove them *) - let relinfo_argsok = { relinfo_noindarg with - nargs = relinfo_noindarg.nargs - nfuns; - (* args is in reverse order, so remove fst *) - args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = popn nfuns relinfo_noindarg.concl - } in - let new_branches = - List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in - let relinfo_branches = { relinfo_argsok with branches = new_branches } in - relinfo_branches - -(* @article{ bundy93rippling, - author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", - title = "Rippling: A Heuristic for Guiding Inductive Proofs", - journal = "Artificial Intelligence", - volume = "62", - number = "2", - pages = "185-253", - year = "1993", - url = "citeseer.ist.psu.edu/bundy93rippling.html" } - - *) -(* -*** Local Variables: *** -*** compile-command: "make -C ../.. contrib/funind/merge.cmo" *** -*** indent-tabs-mode: nil *** -*** End: *** -*) diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml deleted file mode 100644 index 09b7fbdf..00000000 --- a/contrib/funind/rawterm_to_relation.ml +++ /dev/null @@ -1,1262 +0,0 @@ -open Printer -open Pp -open Names -open Term -open Rawterm -open Libnames -open Indfun_common -open Util -open Rawtermops - -let observe strm = - if do_observe () - then Pp.msgnl strm - else () -let observennl strm = - if do_observe () - then Pp.msg strm - else () - - -type binder_type = - | Lambda of name - | Prod of name - | LetIn of name - -type raw_context = (binder_type*rawconstr) list - - -(* - compose_raw_context [(bt_1,n_1,t_1);......] rt returns - b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the - binders corresponding to the bt_i's -*) -let compose_raw_context = - let compose_binder (bt,t) acc = - match bt with - | Lambda n -> mkRLambda(n,t,acc) - | Prod n -> mkRProd(n,t,acc) - | LetIn n -> mkRLetIn(n,t,acc) - in - List.fold_right compose_binder - - -(* - The main part deals with building a list of raw constructor expressions - from the rhs of a fixpoint equation. -*) - -type 'a build_entry_pre_return = - { - context : raw_context; (* the binding context of the result *) - value : 'a; (* The value *) - } - -type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : identifier list - } - -(* - [combine_results combine_fun res1 res2] combine two results [res1] and [res2] - w.r.t. [combine_fun]. - - Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] - and [res2_1,....] and we need to produce - [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] -*) - -let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) - res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = list_union res1.to_avoid res2.to_avoid - } - - -(* - The combination function for an argument with a list of argument -*) - -let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of - [args] in order to preserve possible type dependencies - *) - value = arg.value::args.value; - } - - -let ids_of_binder = function - | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] - -let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if idmap_is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) - -let rec replace_var_by_term_in_binder x_id term = function - | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if List.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l - -let add_bt_names bt = List.append (ids_of_binder bt) - -let apply_args ctxt body args = - let need_convert_id avoid id = - List.exists (is_free_in id) args || List.mem id avoid - in - let need_convert avoid bt = - List.exists (need_convert_id avoid) (ids_of_binder bt) - in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = - match na with - | Name id when List.mem id avoid -> - let new_id = Nameops.next_ident_away id avoid in - Name new_id,Idmap.add id new_id mapping,new_id::avoid - | _ -> na,mapping,avoid - in - let next_bt_away bt (avoid:identifier list) = - match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - Lambda new_na,mapping,new_avoid - in - let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = raw_decompose_app body in - (ctxt,mkRApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = id::avoid in - let new_id = Nameops.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - id::avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body - in - do_apply [] ctxt body args - - -let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of - the applied value in order to preserve possible type dependencies - *) - context = args.context@new_ctxt; - value = new_value; - } - -let combine_lam n t b = - { - context = []; - value = mkRLambda(n, compose_raw_context t.context t.value, - compose_raw_context b.context b.value ) - } - - - -let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} - -let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - - -let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } -(************************************************* - Some functions to deal with overlapping patterns -**************************************************) - -let coq_True_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") - -let coq_False_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") - -(* - [make_discr_match_el \[e1,...en\]] builds match e1,...,en with - (the list of expresions on which we will do the matching) - *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) - -(* - [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. - that is. - match ?????? with \\ - | pat_1 => False \\ - | pat_{i-1} => False \\ - | pat_i => True \\ - | pat_{i+1} => False \\ - \vdots - | pat_n => False - end -*) -let make_discr_match_brl i = - list_map_i - (fun j (_,idl,patl,_) -> - if j=i - then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) - else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) - ) - 0 -(* - [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff - brl_{i} is the first branch matched by [el] - - Used when we want to simulate the coq pattern matching algorithm -*) -let make_discr_match brl = - fun el i -> - mkRCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) - -let pr_name = function - | Name id -> Ppconstr.pr_id id - | Anonymous -> str "_" - -(**********************************************************************) -(* functions used to build case expression from lettuple and if ones *) -(**********************************************************************) - -(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) -let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in - let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - construct - in - let argl = - if argl = [] - then - Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) - ) - else argl - in - let pat_as_term = - mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_rawconstr Anonymous pat_as_term - ) - ind.Declarations.mind_consnames - -(* [find_type_of] very naive attempts to discover the type of an if or a letin *) -let rec find_type_of nb b = - let f,_ = raw_decompose_app b in - match f with - | RRef(_,ref) -> - begin - let ind_type = - match ref with - | VarRef _ | ConstRef _ -> - let constr_of_ref = constr_of_global ref in - let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in - let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in - let ret_type,_ = decompose_app ret_type in - if not (isInd ret_type) then - begin -(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) - raise (Invalid_argument "not an inductive") - end; - destInd ret_type - | IndRef ind -> ind - | ConstructRef c -> fst c - in - let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in - if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) - then raise (Invalid_argument "find_type_of : not a valid inductive"); - ind_type - end - | RCast(_,b,_) -> find_type_of nb b - | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) - | _ -> raise (Invalid_argument "not a ref") - - - - -(******************) -(* Main functions *) -(******************) - - - -let raw_push_named (na,raw_value,raw_typ) env = - match na with - | Anonymous -> env - | Name id -> - let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in - let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in - Environ.push_named (id,value,typ) env - - -let add_pat_variables pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env); - - match pat with - | PatVar(_,na) -> Environ.push_rel (na,None,typ) env - | PatCstr(_,c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) - in - let new_env = add_pat_variables env pat typ in - let res = - fst ( - Sign.fold_rel_context - (fun (na,v,t) (env,ctxt) -> - match na with - | Anonymous -> assert false - | Name id -> - let new_t = substl ctxt t in - let new_v = Option.map (substl ctxt) v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) - ); - (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) - in - observe (str "new var env := " ++ Printer.pr_named_context_of res); - res - - - - -let rec pattern_to_term_and_type env typ = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - mkRVar id - | PatCstr(loc,constr,patternl,_) -> - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in - let csta = Array.of_list cstl in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) - ) - in - let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl - in - mkRApp(mkRRef(ConstructRef constr), - implicit_args@patl_as_term - ) - -(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) - of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the - corresponding graphs. - - - The idea to transform a term [t] into a list of constructors [lc] is the following: - \begin{itemize} - \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding - to [body] and add (bind x. _) to each elements of [lc] - \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) - then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], - [g c1 ... cn] is an element of [lc] - \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then - compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] - create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] - \item if the term is a cast just treat its body part - \item - if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case - and concatenate them (informally, each branch of a match produces a new constructor) - \end{itemize} - - WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. - We must wait to have complete all the current calculi to set the recursive calls. - At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by - a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. - We in fact not create a constructor list since then end of each constructor has not the expected form - but only the value of the function -*) - - -let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = - observe (str " Entering : " ++ Printer.pr_rawconstr rt); - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | RApp(_,_,_) -> - let f,args = raw_decompose_app rt in - let args_res : (rawconstr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match f with - | RVar(_,id) when Idset.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in - let rt_typ = Typing.type_of env Evd.empty rt_as_constr in - let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in - let res = fresh_id args_res.to_avoid "res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkRVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkRApp(f,args_res.value)}) - args_res.result - } - | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) - | RLetIn(_,n,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Nameops.next_ident_away id avoid in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (RVar(dummy_loc,id)) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - funnames - avoid - (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env funnames avoid (mkRApp(b,args)) - | RRec _ -> error "Not handled RRec" - | RProd _ -> error "Cannot apply a type" - end (* end of the application treatement *) - - | RLambda(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | RProd(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_prod n) t_res b_res - | RLetIn(_,n,v,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.Default.understand Evd.empty env v in - let v_type = Typing.type_of env Evd.empty v_as_constr in - let new_env = - match n with - Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env - in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_letin n) v_res b_res - | RCases(_,_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env funnames make_discr el brl avoid - | RIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type ind [] in - assert (Array.length case_pats = 2); - let brl = - list_map_i - (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkRCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) - build_entry_lc env funnames avoid match_expr - | RLetTuple(_,nal,_,b,e) -> - begin - let nal_as_rawconstr = - List.map - (function - Name id -> mkRVar id - | Anonymous -> mkRHole () - ) - nal - in - let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type ind nal_as_rawconstr in - assert (Array.length case_pats = 1); - let br = - (dummy_loc,[],[case_pats.(0)],e) - in - let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env funnames avoid match_expr - - end - | RRec _ -> error "Not handled RRec" - | RCast(_,b,_) -> - build_entry_lc env funnames avoid b - | RDynamic _ -> error "Not handled RDynamic" -and build_entry_lc_from_case env funname make_discr - (el:tomatch_tuples) - (brl:Rawterm.cases_clauses) avoid : - rawconstr build_entry_return = - match el with - | [] -> assert false (* this case correspond to match <nothing> with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each elemeent of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - (****** The next works only if the match is not dependent ****) - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in - Typing.type_of env Evd.empty case_arg_as_constr - ) el - in - let results = - List.map - (build_entry_lc_from_case_term - env types - funname (make_discr (* (List.map fst el) *)) - [] brl - case_resl.to_avoid) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results - } - -and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid - matched_expr = - match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha convertion to prevent name clashes *) - let _,idl,patl,return = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = Typing.type_of env_with_pat_ids Evd.empty (mkVar id) in - let raw_typ_of_id = - Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id - in - mkRProd (Name id,raw_typ_of_id,acc)) - pat_ids - (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* - we first compute the other branch result (in ordrer to keep the order of the matching - as much as possible) - *) - let brl'_res = - build_entry_lc_from_case_term - env - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - list_map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - List.fold_right - (fun id acc -> - if Idset.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in - let raw_typ_of_id = - Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - - ) - idl - [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result - in - { brl'_res with result = this_branch_res@brl'_res.result } - - -let is_res id = - try - String.sub (string_of_id id) 0 3 = "res" - with Invalid_argument _ -> false - -(* - The second phase which reconstruct the real type of the constructor. - rebuild the raw constructors expression. - eliminates some meaningless equalities, applies some rewrites...... -*) -let rec rebuild_cons nb_args relname args crossed_types depth rt = - match rt with - | RProd(_,n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match t with - | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id -> - begin - match args' with - | (RVar(_,this_relname))::args' -> - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - args new_crossed_types - (depth + 1) b - in - (*i The next call to mk_rel_id is valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) - in mkRProd(n,new_t,new_b), - Idset.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | RApp(_,RRef(_,eq_as_ref),[_;RVar(_,id);rt]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous - -> - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkRProd(n,t,new_b),id_to_exclude - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkRProd(n,t,new_b),id_to_exclude - else new_b, Idset.add id id_to_exclude - *) - | _ -> - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude - end - | RLambda(_,n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in - match n with - | Name id -> - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - (args@[mkRVar id])new_crossed_types - (depth + 1 ) b - in - if Idset.mem id id_to_exclude && depth >= nb_args - then - new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - else - RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude - | _ -> anomaly "Should not have an anonymous function here" - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end - | RLetIn(_,n,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> RLetIn(dummy_loc,n,t,new_b), - Idset.filter not_free_in_t id_to_exclude - end - | RLetTuple(_,nal,(na,rto),t,b) -> - assert (rto=None); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons - nb_args - relname - args (crossed_types) - depth t - in - let new_b,id_to_exclude = - rebuild_cons - nb_args relname - args (t::crossed_types) - (depth + 1) b - in -(* match n with *) -(* | Name id when Idset.mem id id_to_exclude -> *) -(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - RLetTuple(dummy_loc,nal,(na,None),t,new_b), - Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') - - end - - | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty - - -(* debuging wrapper *) -let rebuild_cons nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons nb_args relname args crossed_types 0 rt - in -(* observe (str " leads to "++ pr_rawconstr (fst res)); *) - res - - -(* naive implementation of parameter detection. - - A parameter is an argument which is only preceded by parameters and whose - calls are all syntaxically equal. - - TODO: Find a valid way to deal with implicit arguments here! -*) -let rec compute_cst_params relnames params = function - | RRef _ | RVar _ | REvar _ | RPatVar _ -> params - | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> - compute_cst_params_from_app [] (params,rtl) - | RApp(_,f,args) -> - List.fold_left (compute_cst_params relnames) params (f::args) - | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | RCases _ -> - params (* If there is still cases at this point they can only be - discriminitation ones *) - | RSort _ -> params - | RHole _ -> params - | RIf _ | RRec _ | RCast _ | RDynamic _ -> - raise (UserError("compute_cst_params", str "Not handled case")) -and compute_cst_params_from_app acc (params,rtl) = - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = - let rels_params = - Array.mapi - (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) - args - in - let l = ref [] in - let _ = - try - list_iter_i - (fun i ((n,nt,is_defined) as param) -> - if array_for_all - (fun l -> - let (n',nt',is_defined') = List.nth l i in - n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') - rels_params - then - l := param::!l - ) - rels_params.(0) - with _ -> - () - in - List.rev !l - -let rec rebuild_return_type rt = - match rt with - | Topconstr.CProdN(loc,n,t') -> - Topconstr.CProdN(loc,n,rebuild_return_type t') - | Topconstr.CArrow(loc,t,t') -> - Topconstr.CArrow(loc,t,rebuild_return_type t') - | Topconstr.CLetIn(loc,na,t,t') -> - Topconstr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) - - -let do_build_inductive - funnames (funsargs: (Names.name * rawconstr * bool) list list) - returned_types - (rtl:rawconstr list) = - let _time1 = System.get_time () in -(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) - let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in - let funnames = Array.of_list funnames in - let funsargs = Array.of_list funsargs in - let returned_types = Array.of_list returned_types in - (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in - let rta = Array.of_list rtl_alpha in - (*i The next call to mk_rel_id is valid since we are constructing the graph - Ensures by: obvious - i*) - let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in - (* Construction of the pseudo constructors *) - let env = - Array.fold_right - (fun id env -> - Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env - ) - funnames - (Global.env ()) - in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in - (* and of the real constructors*) - let constr i res = - List.map - (function result (* (args',concl') *) -> - let rt = compose_raw_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) - fst ( - rebuild_cons nb_args relnames.(i) - [] - [] - rt - ) - ) - res.result - in - (* adding names to constructors *) - let next_constructor_id = ref (-1) in - let mk_constructor_id i = - incr next_constructor_id; - (*i The next call to mk_rel_id is valid since we are constructing the graph - Ensures by: obvious - i*) - id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) - in - let rel_constructors i rt : (identifier*rawconstr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) - in - let rel_constructors = Array.mapi rel_constructors resa in - (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in - let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors - in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = - (snd (list_chop nrel_params funargs)) - in - List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, - acc) - else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], - acc - ) - ) - rel_first_args - (rebuild_return_type returned_types.(i)) - in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values - *) - let rel_arities = Array.mapi rel_arity funsargs in - let rel_params = - List.map - (fun (n,t,is_defined) -> - if is_defined - then - Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) - else - Topconstr.LocalRawAssum - ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) - ) - rels_params - in - let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((dummy_loc,id), - Flags.with_option - Flags.raw_print - (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) - ) - )) - (rel_constructors) - in - let rel_ind i ext_rel_constructors = - ((dummy_loc,relnames.(i)), - rel_params, - Some rel_arities.(i), - ext_rel_constructors),None - in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in - let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) - let _time2 = System.get_time () in - try - with_full_print (Flags.silently (Command.build_mutual rel_inds)) true - with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,repacked_rel_inds)) - ++ fnl () ++ - Cerrors.explain_exn e - in - observe msg; - raise e - - - -let build_inductive funnames funsargs returned_types rtl = - try - do_build_inductive funnames funsargs returned_types rtl - with e -> raise (Building_graph e) - - diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli deleted file mode 100644 index 0075fb0a..00000000 --- a/contrib/funind/rawterm_to_relation.mli +++ /dev/null @@ -1,16 +0,0 @@ - - - -(* - [build_inductive parametrize funnames funargs returned_types bodies] - constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments - and returning [returned_types] using bodies [bodies] -*) - -val build_inductive : - Names.identifier list -> (* The list of function name *) - (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) - Topconstr.constr_expr list -> (* The list of function returned type *) - Rawterm.rawconstr list -> (* the list of body *) - unit - diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml deleted file mode 100644 index 92396af5..00000000 --- a/contrib/funind/rawtermops.ml +++ /dev/null @@ -1,718 +0,0 @@ -open Pp -open Rawterm -open Util -open Names -(* Ocaml 3.06 Map.S does not handle is_empty *) -let idmap_is_empty m = m = Idmap.empty - -(* - Some basic functions to rebuild rawconstr - In each of them the location is Util.dummy_loc -*) -let mkRRef ref = RRef(dummy_loc,ref) -let mkRVar id = RVar(dummy_loc,id) -let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl) -let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b) -let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b) -let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) -let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl) -let mkRSort s = RSort(dummy_loc,s) -let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) -let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) - -(* - Some basic functions to decompose rawconstrs - These are analogous to the ones constrs -*) -let raw_decompose_prod = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,t)::args) b - | rt -> args,rt - in - raw_decompose_prod [] - -let raw_decompose_prod_or_letin = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod ((n,Some t,None)::args) b - | rt -> args,rt - in - raw_decompose_prod [] - -let raw_compose_prod = - List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) - -let raw_compose_prod_or_letin = - List.fold_left ( - fun concl decl -> - match decl with - | (n,None,Some t) -> mkRProd(n,t,concl) - | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl) - | _ -> assert false) - -let raw_decompose_prod_n n = - let rec raw_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,t)::args) b - | rt -> args,rt - in - raw_decompose_prod n [] - - -let raw_decompose_prod_or_letin_n n = - let rec raw_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod (i-1) ((n,Some t,None)::args) b - | rt -> args,rt - in - raw_decompose_prod n [] - - -let raw_decompose_app = - let rec decompose_rapp acc rt = -(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) - match rt with - | RApp(_,rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | rt -> rt,List.rev acc - in - decompose_rapp [] - - - - -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq ?(typ= mkRHole ()) t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) - -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -let raw_make_neq t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) - -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) -let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) - -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec raw_make_or_list = function - | [] -> raise (Invalid_argument "mk_or") - | [e] -> e - | e::l -> raw_make_or e (raw_make_or_list l) - - -let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Idmap.remove id mapping - -let change_vars = - let rec change_vars mapping rt = - match rt with - | RRef _ -> rt - | RVar(loc,id) -> - let new_id = - try - Idmap.find id mapping - with Not_found -> id - in - RVar(loc,new_id) - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, - name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | RProd(loc,name,k,t,b) -> - RProd(loc, - name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | RLetIn(loc,name,def,b) -> - RLetIn(loc, - name, - change_vars mapping def, - change_vars (remove_name_from_mapping mapping name) b - ) - | RLetTuple(loc,nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - RLetTuple(loc, - nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, - change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) - | RRec _ -> error "Local (co)fixes are not supported" - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv (k,t)) -> - RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,change_vars mapping b,CastCoerce) - | RDynamic _ -> error "Not handled RDynamic" - and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping - then br - else (loc,idl,patl,change_vars new_mapping res) - in - change_vars - - - -let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> - let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty - | PatVar(loc,Name id) -> - if List.mem id excluded - then - let new_id = Nameops.next_ident_away id excluded in - PatVar(loc,Name new_id),(new_id::excluded), - (Idmap.add id new_id Idmap.empty) - else pat,excluded,Idmap.empty - | PatCstr(loc,constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when List.mem id excluded -> - let new_id = Nameops.next_ident_away id excluded in - Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty - | _ -> na,excluded,Idmap.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) - ) - ([],new_excluded,map) - patl - in - PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) - ) - ([],excluded,Idmap.empty) - patl - in - (List.rev patl,new_excluded,map) - - - - -let raw_get_pattern_id pat acc = - let rec get_pattern_id pat = - match pat with - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - [id] - | PatCstr(loc,constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] - in - (get_pattern_id pat)@acc - -let get_pattern_id pat = raw_get_pattern_id pat [] - -let rec alpha_rt excluded rt = - let new_rt = - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | RLambda(loc,Anonymous,k,t,b) -> - let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - RProd(loc,Anonymous,k,new_t,new_b) - | RLetIn(loc,Anonymous,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - RLetIn(loc,Anonymous,new_t,new_b) - | RLambda(loc,Name id,k,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let t,b = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Name id,k,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let new_excluded = new_id::excluded in - let t,b = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RProd(loc,Name new_id,k,new_t,new_b) - | RLetIn(loc,Name id,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let t,b = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RLetIn(loc,Name new_id,new_t,new_b) - - - | RLetTuple(loc,nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Nameops.next_ident_away id excluded in - if new_id = id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) - ) - ([],excluded,Idmap.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if idmap_is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | RIf(loc,b,(na,e_o),lhs,rhs) -> - RIf(loc,alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) - | RRec _ -> error "Not handled RRec" - | RSort _ -> rt - | RHole _ -> rt - | RCast (loc,b,CastConv (k,t)) -> - RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | RCast (loc,b,CastCoerce) -> - RCast(loc,alpha_rt excluded b,CastCoerce) - | RDynamic _ -> error "Not handled RDynamic" - | RApp(loc,f,args) -> - RApp(loc, - alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) - in - new_rt - -and alpha_br excluded (loc,ids,patl,res) = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in - let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in - let renamed_res = change_vars mapping res in - let new_res = alpha_rt new_excluded renamed_res in - (loc,new_ids,new_patl,new_res) - -(* - [is_free_in id rt] checks if [id] is a free variable in [rt] -*) -let is_free_in id = - let rec is_free_in = function - | RRef _ -> false - | RVar(_,id') -> id_ord id' id == 0 - | REvar _ -> false - | RPatVar _ -> false - | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) -> - let check_in_b = - match n with - | Name id' -> id_ord id' id <> 0 - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | RCases(_,_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | RLetTuple(_,nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> id'= id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | RIf(_,cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> false - | RHole _ -> false - | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t - | RCast (_,b,CastCoerce) -> is_free_in b - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and is_free_in_br (_,ids,_,rt) = - (not (List.mem id ids)) && is_free_in rt - in - is_free_in - - - -let rec pattern_to_term = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - mkRVar id - | PatCstr(loc,constr,patternl,_) -> - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkRHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkRApp(mkRRef(Libnames.ConstructRef constr), - implicit_args@patl_as_term - ) - - - -let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | RRef _ -> rt - | RVar(_,id) when id_ord id x_id == 0 -> term - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RLambda(loc,name,k,t,b) -> - RLambda(loc, - name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RProd(loc,name,k,t,b) -> - RProd(loc, - name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) - | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RLetIn(loc,name,def,b) -> - RLetIn(loc, - name, - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | RLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> - rt - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, - nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> - RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,replace_var_by_pattern b,CastCoerce) - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl - then br - else (loc,idl,patl,replace_var_by_pattern res) - in - replace_var_by_pattern - - - - -(* checking unifiability of patterns *) -exception NotUnifiable - -let rec are_unifiable_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 - then raise NotUnifiable - else - let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" - in - are_unifiable_aux eqs' - -let are_unifiable pat1 pat2 = - try - are_unifiable_aux [pat1,pat2]; - true - with NotUnifiable -> false - - -let rec eq_cases_pattern_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 - then raise NotUnifiable - else - let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable - -let eq_cases_pattern pat1 pat2 = - try - eq_cases_pattern_aux [pat1,pat2]; - true - with NotUnifiable -> false - - - -let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids - | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl - in - ids_of_pat Idset.empty - -let id_of_name = function - | Names.Anonymous -> id_of_string "x" - | Names.Name x -> x - -(* TODO: finish Rec caes *) -let ids_of_rawterm c = - let rec ids_of_rawterm acc c = - let idof = id_of_name in - match c with - | RVar (_,id) -> id::acc - | RApp (loc,g,args) -> - ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc - | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc - | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc - | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc - | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc - | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc - | RLetTuple (_,nal,(na,po),b,c) -> - List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCases (loc,sty,rtntypopt,tml,brchl) -> - List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) - | RRec _ -> failwith "Fix inside a constructor branch" - | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> [] - in - (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) - - - - - -let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | RRef _ -> rt - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - zeta_normalize_term rt', - List.map zeta_normalize_term rtl - ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | RProd(loc,name,k,t,b) -> - RProd(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | RLetIn(_,Name id,def,b) -> - zeta_normalize_term (replace_var_by_term id def b) - | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, - nal, - (na,Option.map zeta_normalize_term rto), - zeta_normalize_term def, - zeta_normalize_term b - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, - infos, - List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, - List.map zeta_normalize_br brl - ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, zeta_normalize_term b, - (na,Option.map zeta_normalize_term e_option), - zeta_normalize_term lhs, - zeta_normalize_term rhs - ) - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> - RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,zeta_normalize_term b,CastCoerce) - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and zeta_normalize_br (loc,idl,patl,res) = - (loc,idl,patl,zeta_normalize_term res) - in - zeta_normalize_term - - - - -let expand_as = - - let rec add_as map pat = - match pat with - | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> - Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) - | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl - in - let rec expand_as map rt = - match rt with - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt - | RVar(_,id) -> - begin - try - Idmap.find id map - with Not_found -> rt - end - | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) - | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) - | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b) - | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b) - | RLetTuple(loc,nal,(na,po),v,b) -> - RLetTuple(loc,nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) - | RIf(loc,e,(na,po),br1,br2) -> - RIf(loc,expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | RRec _ -> error "Not handled RRec" - | RDynamic _ -> error "Not handled RDynamic" - | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t)) - | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce) - | RCases(loc,sty,po,el,brl) -> - RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = - (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) - in - expand_as Idmap.empty diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli deleted file mode 100644 index 358c6ba6..00000000 --- a/contrib/funind/rawtermops.mli +++ /dev/null @@ -1,126 +0,0 @@ -open Rawterm - -(* Ocaml 3.06 Map.S does not handle is_empty *) -val idmap_is_empty : 'a Names.Idmap.t -> bool - - -(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) -val get_pattern_id : cases_pattern -> Names.identifier list - -(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern -*) -val pattern_to_term : cases_pattern -> rawconstr - -(* - Some basic functions to rebuild rawconstr - In each of them the location is Util.dummy_loc -*) -val mkRRef : Libnames.global_reference -> rawconstr -val mkRVar : Names.identifier -> rawconstr -val mkRApp : rawconstr*(rawconstr list) -> rawconstr -val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr -val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr -val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr -val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr -val mkRSort : rawsort -> rawconstr -val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) -val mkRCast : rawconstr* rawconstr -> rawconstr -(* - Some basic functions to decompose rawconstrs - These are analogous to the ones constrs -*) -val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin : - rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr -val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin_n : int -> rawconstr -> - (Names.name*rawconstr option*rawconstr option) list * rawconstr -val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr -val raw_compose_prod_or_letin: rawconstr -> - (Names.name*rawconstr option*rawconstr option) list -> rawconstr -val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) - - -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -val raw_make_neq : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) -val raw_make_or : rawconstr -> rawconstr -> rawconstr - -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -val raw_make_or_list : rawconstr list -> rawconstr - - -(* alpha_conversion functions *) - - - -(* Replace the var mapped in the rawconstr/context *) -val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr - - - -(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. - the result does not share variables with [avoid]. This function create - a fresh variable for each occurence of the anonymous pattern. - - Also returns a mapping from old variables to new ones and the concatenation of - [avoid] with the variables appearing in the result. -*) - val alpha_pat : - Names.Idmap.key list -> - Rawterm.cases_pattern -> - Rawterm.cases_pattern * Names.Idmap.key list * - Names.identifier Names.Idmap.t - -(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt - conventions and does not share bound variables with avoid -*) -val alpha_rt : Names.identifier list -> rawconstr -> rawconstr - -(* same as alpha_rt but for case branches *) -val alpha_br : Names.identifier list -> - Util.loc * Names.identifier list * Rawterm.cases_pattern list * - Rawterm.rawconstr -> - Util.loc * Names.identifier list * Rawterm.cases_pattern list * - Rawterm.rawconstr - - -(* Reduction function *) -val replace_var_by_term : - Names.identifier -> - Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr - - - -(* - [is_free_in id rt] checks if [id] is a free variable in [rt] -*) -val is_free_in : Names.identifier -> rawconstr -> bool - - -val are_unifiable : cases_pattern -> cases_pattern -> bool -val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - - -(* - ids_of_pat : cases_pattern -> Idset.t - returns the set of variables appearing in a pattern -*) -val ids_of_pat : cases_pattern -> Names.Idset.t - -(* TODO: finish this function (Fix not treated) *) -val ids_of_rawterm: rawconstr -> Names.Idset.t - -(* - removing let_in construction in a rawterm -*) -val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr - - -val expand_as : rawconstr -> rawconstr diff --git a/contrib/funind/recdef.ml b/contrib/funind/recdef.ml deleted file mode 100644 index 14bf7cf8..00000000 --- a/contrib/funind/recdef.ml +++ /dev/null @@ -1,1436 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: recdef.ml 12221 2009-07-04 21:53:12Z jforest $ *) - -open Term -open Termops -open Environ -open Declarations -open Entries -open Pp -open Names -open Libnames -open Nameops -open Util -open Closure -open RedFlags -open Tacticals -open Typing -open Tacmach -open Tactics -open Nametab -open Decls -open Declare -open Decl_kinds -open Tacred -open Proof_type -open Vernacinterp -open Pfedit -open Topconstr -open Rawterm -open Pretyping -open Pretyping.Default -open Safe_typing -open Constrintern -open Hiddentac - -open Equality -open Auto -open Eauto - -open Genarg - - -let compute_renamed_type gls c = - rename_bound_var (pf_env gls) [] (pf_type_of gls c) - -let qed () = Command.save_named true -let defined () = Command.save_named false - -let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in - List.fold_right - (fun id acc -> next_global_ident_away false id (acc@ids)::acc) - idl - [] - -let pf_get_new_id id g = - List.hd (pf_get_new_ids [id] g) - -let h_intros l = - tclMAP h_intro l - -let do_observe_tac s tac g = - let goal = begin (Printer.pr_goal (sig_it g)) end in - try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++ - (str s)++(str " ")++(str "finished")); v - with e -> - msgnl (str "observation "++str s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; - - -let observe_tac s tac g = - if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then do_observe_tac s tac g - else tac g - -let hyp_ids = List.map id_of_string - ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res"; - "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];; - -let rec nthtl = function - l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];; - -let hyp_id n l = List.nth l n;; - -let (x_id:identifier) = hyp_id 0 hyp_ids;; -let (v_id:identifier) = hyp_id 1 hyp_ids;; -let (k_id:identifier) = hyp_id 2 hyp_ids;; -let (def_id:identifier) = hyp_id 3 hyp_ids;; -let (p_id:identifier) = hyp_id 4 hyp_ids;; -let (h_id:identifier) = hyp_id 5 hyp_ids;; -let (n_id:identifier) = hyp_id 6 hyp_ids;; -let (h'_id:identifier) = hyp_id 7 hyp_ids;; -let (ano_id:identifier) = hyp_id 8 hyp_ids;; -let (rec_res_id:identifier) = hyp_id 10 hyp_ids;; -let (hspec_id:identifier) = hyp_id 11 hyp_ids;; -let (heq_id:identifier) = hyp_id 12 hyp_ids;; -let (hrec_id:identifier) = hyp_id 13 hyp_ids;; -let (hex_id:identifier) = hyp_id 14 hyp_ids;; -let (teq_id:identifier) = hyp_id 15 hyp_ids;; -let (pmax_id:identifier) = hyp_id 16 hyp_ids;; -let (hle_id:identifier) = hyp_id 17 hyp_ids;; - -let message s = if Flags.is_verbose () then msgnl(str s);; - -let def_of_const t = - match (kind_of_term t) with - Const sp -> - (try (match (Global.lookup_constant sp) with - {const_body=Some c} -> Declarations.force c - |_ -> assert false) - with _ -> - anomaly ("Cannot find definition of constant "^ - (string_of_id (id_of_label (con_label sp)))) - ) - |_ -> assert false - -let type_of_const t = - match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp - |_ -> assert false - -let arg_type t = - match kind_of_term (def_of_const t) with - Lambda(a,b,c) -> b - | _ -> assert false;; - -let evaluable_of_global_reference r = - match r with - ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id - | _ -> assert false;; - - -let rank_for_arg_list h = - let predicate a b = - try List.for_all2 eq_constr a b with - Invalid_argument _ -> false in - let rec rank_aux i = function - | [] -> None - | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in - rank_aux 0;; - -let rec (find_call_occs : int -> constr -> constr -> - (constr list -> constr) * constr list list) = - fun nb_lam f expr -> - match (kind_of_term expr) with - App (g, args) when g = f -> - (fun l -> List.hd l), [Array.to_list args] - | App (g, args) -> - let (largs: constr list) = Array.to_list args in - let rec find_aux = function - [] -> (fun x -> []), [] - | a::upper_tl -> - (match find_aux upper_tl with - (cf, ((arg1::args) as args_for_upper_tl)) -> - (match find_call_occs nb_lam f a with - cf2, (_ :: _ as other_args) -> - let rec avoid_duplicates args = - match args with - | [] -> (fun _ -> []), [] - | h::tl -> - let recomb_tl, args_for_tl = - avoid_duplicates tl in - match rank_for_arg_list h args_for_upper_tl with - | None -> - (fun l -> List.hd l::recomb_tl(List.tl l)), - h::args_for_tl - | Some i -> - (fun l -> List.nth l (i+List.length args_for_tl):: - recomb_tl l), - args_for_tl - in - let recombine, other_args' = - avoid_duplicates other_args in - let len1 = List.length other_args' in - (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), - other_args'@args_for_upper_tl - | _, [] -> (fun x -> a::cf x), args_for_upper_tl) - | _, [] -> - (match find_call_occs nb_lam f a with - cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) - | _, [] -> (fun x -> a::upper_tl), [])) in - begin - match (find_aux largs) with - cf, [] -> (fun l -> mkApp(g, args)), [] - | cf, args -> - (fun l -> mkApp (g, Array.of_list (cf l))), args - end - | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) - | Var(id) -> (fun l -> expr), [] - | Meta(_) -> error "find_call_occs : Meta" - | Evar(_) -> error "find_call_occs : Evar" - | Sort(_) -> (fun l -> expr), [] - | Cast(b,_,_) -> find_call_occs nb_lam f b - | Prod(_,_,_) -> error "find_call_occs : Prod" - | Lambda(na,t,b) -> - begin - match find_call_occs (succ nb_lam) f b with - | _, [] -> (* Lambda are authorized as long as they do not contain - recursives calls *) - (fun l -> expr),[] - | _ -> error "find_call_occs : Lambda" - end - | LetIn(na,v,t,b) -> - begin - match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with - | (_,[]),(_,[]) -> - ((fun l -> expr), []) - | (_,[]),(cf,(_::_ as l)) -> - ((fun l -> mkLetIn(na,v,t,cf l)),l) - | (cf,(_::_ as l)),(_,[]) -> - ((fun l -> mkLetIn(na,cf l,t,b)), l) - | _ -> error "find_call_occs : LetIn" - end - | Const(_) -> (fun l -> expr), [] - | Ind(_) -> (fun l -> expr), [] - | Construct (_, _) -> (fun l -> expr), [] - | Case(i,t,a,r) -> - (match find_call_occs nb_lam f a with - cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) - | _ -> (fun l -> expr),[]) - | Fix(_) -> error "find_call_occs : Fix" - | CoFix(_) -> error "find_call_occs : CoFix";; - -let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ Coqlib.arith_modules) s;; - -let constant sl s = - constr_of_global - (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; - -let find_reference sl s = - (locate (make_qualid(Names.make_dirpath - (List.map id_of_string (List.rev sl))) - (id_of_string s)));; - -let delayed_force f = f () - -let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant "le_lt_n_Sm") - -let le_trans = function () -> (coq_constant "le_trans") -let le_lt_trans = function () -> (coq_constant "le_lt_trans") -let lt_S_n = function () -> (coq_constant "lt_S_n") -let le_n = function () -> (coq_constant "le_n") -let refl_equal = function () -> (coq_constant "refl_equal") -let eq = function () -> (coq_constant "eq") -let ex = function () -> (coq_constant "ex") -let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_sig = function () -> (coq_constant "sig") -let coq_O = function () -> (coq_constant "O") -let coq_S = function () -> (coq_constant "S") - -let gt_antirefl = function () -> (coq_constant "gt_irrefl") -let lt_n_O = function () -> (coq_constant "lt_n_O") -let lt_n_Sn = function () -> (coq_constant "lt_n_Sn") - -let f_equal = function () -> (coq_constant "f_equal") -let well_founded_induction = function () -> (coq_constant "well_founded_induction") -let well_founded = function () -> (coq_constant "well_founded") -let acc_rel = function () -> (coq_constant "Acc") -let acc_inv_id = function () -> (coq_constant "Acc_inv") -let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") -let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded") -let max_ref = function () -> (find_reference ["Recdef"] "max") -let iter = function () -> (constr_of_global (delayed_force iter_ref)) -let max_constr = function () -> (constr_of_global (delayed_force max_ref)) - -let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") -let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj" - -(* These are specific to experiments in nat with lt as well_founded_relation, *) -(* but this should be made more general. *) -let nat = function () -> (coq_constant "nat") -let lt = function () -> (coq_constant "lt") - -(* This is simply an implementation of the case_eq tactic. this code - should be replaced with the tactic defined in Ltac in Init/Tactics.v *) -let mkCaseEq a : tactic = - (fun g -> - let type_of_a = pf_type_of g a in - tclTHENLIST - [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; - (fun g2 -> - change_in_concl None - (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) - g2); - simplest_case a] g);; - -(* This is like the previous one except that it also rewrite on all - hypotheses except the ones given in the first argument. All the - modified hypotheses are generalized in the process and should be - introduced back later; the result is the pair of the tactic and the - list of hypotheses that have been generalized and cleared. *) -let mkDestructEq : - identifier list -> constr -> goal sigma -> tactic * identifier list = - fun not_on_hyp expr g -> - let hyps = pf_hyps g in - let to_revert = - Util.map_succeed - (fun (id,_,t) -> - if List.mem id not_on_hyp || not (Termops.occur_term expr t) - then failwith "is_expr_context"; - id) hyps in - let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_type_of g expr in - let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: - to_revert_constr in - tclTHENLIST - [h_generalize new_hyps; - (fun g2 -> - change_in_concl None - (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); - simplest_case expr], to_revert - -let rec mk_intros_and_continue thin_intros (extra_eqn:bool) - cont_function (eqs:constr list) nb_lam (expr:constr) g = - let finalize () = if extra_eqn then - let teq = pf_get_new_id teq_id g in - tclTHENLIST - [ h_intro teq; - thin thin_intros; - h_intros thin_intros; - - tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) - (List.rev eqs); - (fun g1 -> - let ty_teq = pf_type_of g1 (mkVar teq) in - let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in - args.(1),args.(2) - in - cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 - ) - ] - g - else - tclTHENSEQ[ - thin thin_intros; - h_intros thin_intros; - cont_function eqs expr - ] g - in - if nb_lam = 0 - then finalize () - else - match kind_of_term expr with - | Lambda (n, _, b) -> - let n1 = - match n with - Name x -> x - | Anonymous -> ano_id - in - let new_n = pf_get_new_id n1 g in - tclTHEN (h_intro new_n) - (mk_intros_and_continue thin_intros extra_eqn cont_function eqs - (pred nb_lam) (subst1 (mkVar new_n) b)) g - | _ -> - assert false -(* finalize () *) -let const_of_ref = function - ConstRef kn -> kn - | _ -> anomaly "ConstRef expected" - -let simpl_iter clause = - reduce - (Lazy - {rBeta=true;rIota=true;rZeta= true; rDelta=false; - rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) -(* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *) - clause - -(* The boolean value is_mes expresses that the termination is expressed - using a measure function instead of a well-founded relation. *) -let tclUSER tac is_mes l g = - let clear_tac = - match l with - | None -> h_clear true [] - | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) - in - tclTHENSEQ - [ - clear_tac; - if is_mes - then tclTHEN - (unfold_in_concl [(all_occurrences, evaluable_of_global_reference - (delayed_force ltof_ref))]) - tac - else tac - ] - g - - -let list_rewrite (rev:bool) (eqs: constr list) = - tclREPEAT - (List.fold_right - (fun eq i -> tclORELSE (rewriteLR eq) i) - (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; - -let base_leaf_terminate (func:global_reference) eqs expr = -(* let _ = msgnl (str "entering base_leaf") in *) - (fun g -> - let k',h = - match pf_get_new_ids [k_id;h_id] g with - [k';h] -> k',h - | _ -> assert false - in - tclTHENLIST - [observe_tac "first split" (split (ImplicitBindings [expr])); - observe_tac "second split" - (split (ImplicitBindings [delayed_force coq_O])); - observe_tac "intro k" (h_intro k'); - observe_tac "case on k" - (tclTHENS (simplest_case (mkVar k')) - [(tclTHEN (h_intro h) - (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, - [| delayed_force coq_O |]))) - default_auto)); tclIDTAC ]); - intros; - simpl_iter onConcl; - unfold_constr func; - list_rewrite true eqs; - default_auto] g);; - -(* La fonction est donnee en premier argument a la - fonctionnelle suivie d'autres Lambdas et de Case ... - Pour recuperer la fonction f a partir de la - fonctionnelle *) - -let get_f foncl = - match (kind_of_term (def_of_const foncl)) with - Lambda (Name f, _, _) -> f - |_ -> error "la fonctionnelle est mal definie";; - - -let rec compute_le_proofs = function - [] -> assumption - | a::tl -> - tclORELSE assumption - (tclTHENS - (fun g -> - let le_trans = delayed_force le_trans in - let t_le_trans = compute_renamed_type g le_trans in - let m_id = - let _,_,t = destProd t_le_trans in - let na,_,_ = destProd t in - Nameops.out_name na - in - apply_with_bindings - (le_trans, - ExplicitBindings[dummy_loc,NamedHyp m_id,a]) - g) - [compute_le_proofs tl; - tclORELSE (apply (delayed_force le_n)) assumption]) - -let make_lt_proof pmax le_proof = - tclTHENS - (fun g -> - let le_lt_trans = delayed_force le_lt_trans in - let t_le_lt_trans = compute_renamed_type g le_lt_trans in - let m_id = - let _,_,t = destProd t_le_lt_trans in - let na,_,_ = destProd t in - Nameops.out_name na - in - apply_with_bindings - (le_lt_trans, - ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) - [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); - tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; - -let rec list_cond_rewrite k def pmax cond_eqs le_proofs = - match cond_eqs with - [] -> tclIDTAC - | eq::eqs -> - (fun g -> - let t_eq = compute_renamed_type g (mkVar eq) in - let k_id,def_id = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in - Nameops.out_name k_na,Nameops.out_name def_na - in - tclTHENS - (general_rewrite_bindings false all_occurrences - (mkVar eq, - ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; - dummy_loc, NamedHyp def_id, mkVar def]) false) - [list_cond_rewrite k def pmax eqs le_proofs; - observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g - ) - -let rec introduce_all_equalities func eqs values specs bound le_proofs - cond_eqs = - match specs with - [] -> - fun g -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp(delayed_force coq_S, [|bound|]) in - let k = next_global_ident_away true k_id ids in - let ids = k::ids in - let h' = next_global_ident_away true (h'_id) ids in - let ids = h'::ids in - let def = next_global_ident_away true def_id ids in - tclTHENLIST - [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max])); - observe_tac "introduce_all_equalities_final intro k" (h_intro k); - tclTHENS - (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k))) - [ - tclTHENLIST[h_intro h'; - simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); - default_full_auto]; - tclIDTAC - ]; - observe_tac "clearing k " (clear [k]); - observe_tac "intros k h' def" (h_intros [k;h';def]); - observe_tac "simple_iter" (simpl_iter onConcl); - observe_tac "unfold functional" - (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); - observe_tac "rewriting equations" - (list_rewrite true eqs); - observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); - observe_tac "refl equal" (apply (delayed_force refl_equal))] g - | spec1::specs -> - fun g -> - let ids = ids_of_named_context (pf_hyps g) in - let p = next_global_ident_away true p_id ids in - let ids = p::ids in - let pmax = next_global_ident_away true pmax_id ids in - let ids = pmax::ids in - let hle1 = next_global_ident_away true hle_id ids in - let ids = hle1::ids in - let hle2 = next_global_ident_away true hle_id ids in - let ids = hle2::ids in - let heq = next_global_ident_away true heq_id ids in - tclTHENLIST - [simplest_elim (mkVar spec1); - list_rewrite true eqs; - h_intros [p; heq]; - simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); - h_intros [pmax; hle1; hle2]; - introduce_all_equalities func eqs values specs - (mkVar pmax) ((mkVar pmax)::le_proofs) - (heq::cond_eqs)] g;; - -let string_match s = - if String.length s < 3 then failwith "string_match"; - try - for i = 0 to 3 do - if String.get s i <> String.get "Acc_" i then failwith "string_match" - done; - with Invalid_argument _ -> failwith "string_match" - -let retrieve_acc_var g = - (* Julien: I don't like this version .... *) - let hyps = pf_ids_of_hyps g in - map_succeed - (fun id -> string_match (string_of_id id);id) - hyps - -let rec introduce_all_values concl_tac is_mes acc_inv func context_fn - eqs hrec args values specs = - (match args with - [] -> - tclTHENLIST - [observe_tac "split" (split(ImplicitBindings - [context_fn (List.map mkVar (List.rev values))])); - observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs - (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] - | arg::args -> - (fun g -> - let ids = ids_of_named_context (pf_hyps g) in - let rec_res = next_global_ident_away true rec_res_id ids in - let ids = rec_res::ids in - let hspec = next_global_ident_away true hspec_id ids in - let tac = - observe_tac "introduce_all_values" ( - introduce_all_values concl_tac is_mes acc_inv func context_fn eqs - hrec args - (rec_res::values)(hspec::specs)) in - (tclTHENS - (observe_tac "elim h_rec" - (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) - ) - [tclTHENLIST [h_intros [rec_res; hspec]; - tac]; - (tclTHENS - (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) - [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) - (observe_tac "h_assumption" h_assumption) - ; - tclTHENLIST - [ - tclTRY(list_rewrite true eqs); - observe_tac "user proof" - (fun g -> - tclUSER - concl_tac - is_mes - (Some (hrec::hspec::(retrieve_acc_var g)@specs)) - g - ) - ] - ] - ) - ]) g) - - ) - - -let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = - match find_call_occs 0 f_constr expr with - | context_fn, args -> - observe_tac "introduce_all_values" - (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) - -let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) - (f_constr:constr) (func:global_reference) base_leaf rec_leaf = - let rec proveterminate (eqs:constr list) (expr:constr) = - try - (* let _ = msgnl (str "entering proveterminate") in *) - let v = - match (kind_of_term expr) with - Case (ci, t, a, l) -> - (match find_call_occs 0 f_constr a with - _,[] -> - (fun g -> - let destruct_tac, rev_to_thin_intro = - mkDestructEq rec_arg_id a g in - tclTHENS destruct_tac - (list_map_i - (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) - true - proveterminate - eqs - ci.ci_cstr_nargs.(i)) - 0 (Array.to_list l)) g) - | _, _::_ -> - (match find_call_occs 0 f_constr expr with - _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) - | _, _:: _ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr))) - | _ -> - (match find_call_occs 0 f_constr expr with - _,[] -> - (try observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> (msgerrnl (str "failure in base case");raise e )) - | _, _::_ -> - observe_tac "rec_leaf" - (rec_leaf is_mes acc_inv hrec func eqs expr)) in - v - with e -> begin msgerrnl(str "failure in proveterminate"); raise e end - in - proveterminate - -let hyp_terminates nb_args func = - let a_arrow_b = arg_type (constr_of_global func) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in - let left = - mkApp(delayed_force iter, - Array.of_list - (lift 5 a_arrow_b:: mkRel 3:: - constr_of_global func::mkRel 1:: - List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) - ) - ) - in - let right = mkRel 5 in - let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in - let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in - let nb_iter = - mkApp(delayed_force ex, - [|delayed_force nat; - (mkLambda - (Name - p_id, - delayed_force nat, - (mkProd (Name k_id, delayed_force nat, - mkArrow cond result))))|])in - let value = mkApp(delayed_force coq_sig, - [|b; - (mkLambda (Name v_id, b, nb_iter))|]) in - compose_prod rev_args value - - - -let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes - then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) - else tclUSER concl_tac is_mes names_to_suppress - -let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map - mkVar (fst (list_chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in - let wf_rec_arg = - next_global_ident_away true - (id_of_string ("Acc_"^(string_of_id rec_arg_id))) - (wf_thm::ids) - in - let hrec = next_global_ident_away true hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = - lazy ( - mkApp ( - delayed_force acc_inv_id, - [|input_type;relation;mkVar rec_arg_id|] - ) - ) - in - tclTHEN - (h_intros args_id) - (tclTHENS - (observe_tac - "first assert" - (assert_tac - (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, - [|input_type;relation;mkVar rec_arg_id|]) - ) - ) - ) - [ - (* accesibility proof *) - tclTHENS - (observe_tac - "second assert" - (assert_tac - (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) - ) - ) - [ - (* interactive proof that the relation is well_founded *) - observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); - (* this gives the accessibility argument *) - observe_tac - "apply wf_thm" - (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) - ) - ] - ; - (* rest of the proof *) - tclTHENSEQ - [observe_tac "generalize" - (onNLastHyps (nargs+1) - (fun (id,_,_) -> - tclTHEN (h_generalize [mkVar id]) (h_clear false [id]) - )) - ; - observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); - h_intros args_id; - h_intro wf_rec_arg; - observe_tac "tac" (tac wf_rec_arg hrec acc_inv) - ] - ] - ) g - end - - - -let rec instantiate_lambda t l = - match l with - | [] -> t - | a::l -> - let (bound_name, _, body) = destLambda t in - instantiate_lambda (subst1 a body) l -;; - - -let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> - let ids = ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_global func)) in - let (f_name, _, body1) = destLambda func_body in - let f_id = - match f_name with - | Name f_id -> next_global_ident_away true f_id ids - | Anonymous -> anomaly "Anonymous function" - in - let n_names_types,_ = decompose_lam_n nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name with - | Name id -> - let n_id = next_global_ident_away true id ids in - n_id::n_ids,n_id::ids - | _ -> anomaly "anonymous argument" - ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header - is_mes - input_type - ids - n_ids - relation - rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_inv g -> - (proveterminate - [rec_arg_id] - is_mes - acc_inv - hrec - (mkVar f_id) - func - base_leaf_terminate - (rec_leaf_terminate (mkVar f_id) concl_tac) - [] - expr - ) - g - ) - (tclUSER_if_not_mes concl_tac) - g - end - -let get_current_subgoals_types () = - let pts = get_pftreestate () in - let _,subs = extract_open_pftreestate pts in - List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) - -let build_and_l l = - let and_constr = Coqlib.build_coq_and () in - let conj_constr = coq_conj () in - let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in - let rec f = function - | [] -> failwith "empty list of subgoals!" - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, - tclTHENS - (apply (constr_of_global conj_constr)) - [tclIDTAC; - tac - ],nb+1 - in f l - - -let is_rec_res id = - let rec_res_name = string_of_id rec_res_id in - let id_name = string_of_id id in - try - String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with _ -> false - -let clear_goals = - let rec clear_goal t = - match kind_of_term t with - | Prod(Name id as na,t,b) -> - let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) - then pop b' - else if b' == b then t - else mkProd(na,t,b') - | _ -> map_constr clear_goal t - in - List.map clear_goal - - -let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in - let sub_gls_types = clear_goals sub_gls_types in - let res = build_and_l sub_gls_types in - res - - - (* -let prove_with_tcc lemma _ : tactic = - fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ - [ - h_generalize [lemma]; - h_intro hid; - Elim.h_decompose_and (mkVar hid); - gen_eauto(* default_eauto *) false (false,5) [] (Some []) - (* default_auto *) - ] - gls - *) - - - -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = - let current_proof_name = get_current_proof_name () in - let name = match goal_name with - | Some s -> s - | None -> - try (add_suffix current_proof_name "_subproof") - with _ -> anomaly "open_new_goal with an unamed theorem" - in - let sign = Global.named_context () in - let sign = clear_proofs sign in - let na = next_global_ident_away false name [] in - if occur_existential gls_type then - Util.error "\"abstract\" cannot handle existentials"; - let hook _ _ = - let opacity = - let na_ref = Libnames.Ident (dummy_loc,na) in - let na_global = Nametab.global na_ref in - match na_global with - ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end - | _ -> anomaly "equation_lemma: not a constant" - in - let lemma = mkConst (Lib.make_con na) in - ref_ := Some lemma ; - let lid = ref [] in - let h_num = ref (-1) in - Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); - build_proof - ( fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ - [ - h_generalize [lemma]; - h_intro hid; - (fun g -> - let ids = pf_ids_of_hyps g in - tclTHEN - (Elim.h_decompose_and (mkVar hid)) - (fun g -> - let ids' = pf_ids_of_hyps g in - lid := List.rev (list_subtract ids' ids); - if !lid = [] then lid := [hid]; - tclIDTAC g - ) - g - ); - ] gls) - (fun g -> - match kind_of_term (pf_concl g) with - | App(f,_) when eq_constr f (well_founded ()) -> - Auto.h_auto None [] (Some []) g - | _ -> - incr h_num; - (observe_tac "finishing using" - ( - tclCOMPLETE( - tclFIRST[ - tclTHEN - (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption; - Eauto.eauto_with_bases - false - (true,5) - [delayed_force refl_equal] - [Auto.Hint_db.empty empty_transparent_state false] - ] - ) - ) - ) - g) -; - Command.save_named opacity; - in - start_proof - na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) - sign - gls_type - hook ; - by ( - fun g -> - tclTHEN - (decompose_and_tac) - (tclORELSE - (tclFIRST - (List.map - (fun c -> - tclTHENSEQ - [intros; - h_simplest_apply (interp_constr Evd.empty (Global.env()) c); - tclCOMPLETE Auto.default_auto - ] - ) - using_lemmas) - ) tclIDTAC) - g); - try - by tclIDTAC; (* raises UserError _ if the proof is complete *) - if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) - with UserError _ -> - defined () - -;; - - -let com_terminate - tcc_lemma_name - tcc_lemma_ref - is_mes - fonctional_ref - input_type - relation - rec_arg_num - thm_name using_lemmas - nb_args - hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = - let (evmap, env) = Command.get_current_context() in - start_proof thm_name - (Global, Proof Lemma) (Environ.named_context_val env) - (hyp_terminates nb_args fonctional_ref) hook; - by (observe_tac "starting_tac" tac_start); - by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref - input_type relation rec_arg_num )) - - in - start_proof tclIDTAC tclIDTAC; - try - let new_goal_type = build_new_goal_type () in - open_new_goal start_proof using_lemmas tcc_lemma_ref - (Some tcc_lemma_name) - (new_goal_type) - with Failure "empty list of subgoals!" -> - (* a non recursive function declared with measure ! *) - defined () - - - - -let ind_of_ref = function - | IndRef (ind,i) -> (ind,i) - | _ -> anomaly "IndRef expected" - -let (value_f:constr list -> global_reference -> constr) = - fun al fterm -> - let d0 = dummy_loc in - let rev_x_id_l = - ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_global_ident_away true x_id x_id_l in - x_id::x_id_l - ) - [] - al - ) - in - let fun_body = - RCases - (d0,RegularStyle,None, - [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l), - (Anonymous,None)], - [d0, [v_id], [PatCstr(d0,(ind_of_ref - (delayed_force coq_sig_ref),1), - [PatVar(d0, Name v_id); - PatVar(d0, Anonymous)], - Anonymous)], - RVar(d0,v_id)]) - in - let value = - List.fold_left2 - (fun acc x_id a -> - RLambda - (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), - acc - ) - ) - fun_body - rev_x_id_l - (List.rev al) - in - understand Evd.empty (Global.env()) value;; - -let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = - fun f_id kind value -> - let ce = {const_entry_body = value; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = true} in - ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; - -let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = - fun f_id kind input_type fterm_ref -> - declare_fun f_id kind (value_f input_type fterm_ref);; - -let rec n_x_id ids n = - if n = 0 then [] - else let x = next_global_ident_away true x_id ids in - x::n_x_id (x::ids) (n-1);; - -let start_equation (f:global_reference) (term_f:global_reference) - (cont_tactic:identifier list -> tactic) g = - let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in - let x = n_x_id ids nargs in - tclTHENLIST [ - h_intros x; - unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; - observe_tac "simplest_case" - (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x)))); - observe_tac "prove_eq" (cont_tactic x)] g;; - -let base_leaf_eq func eqs f_id g = - let ids = pf_ids_of_hyps g in - let k = next_global_ident_away true k_id ids in - let p = next_global_ident_away true p_id (k::ids) in - let v = next_global_ident_away true v_id (p::k::ids) in - let heq = next_global_ident_away true heq_id (v::p::k::ids) in - let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in - let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in - tclTHENLIST [ - h_intros [v; hex]; - simplest_elim (mkVar hex); - h_intros [p;heq1]; - tclTRY - (rewriteRL - (mkApp(mkVar heq1, - [|mkApp (delayed_force coq_S, [|mkVar p|]); - mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); - simpl_iter onConcl; - tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]); - list_rewrite true eqs; - apply (delayed_force refl_equal)] g;; - -let f_S t = mkApp(delayed_force coq_S, [|t|]);; - - -let rec introduce_all_values_eq cont_tac functional termine - f p heq1 pmax bounds le_proofs eqs ids = - function - [] -> - let heq2 = next_global_ident_away true heq_id ids in - tclTHENLIST - [pose_proof (Name heq2) - (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); - simpl_iter (onHyp heq2); - unfold_in_hyp [((true,[1]), evaluable_of_global_reference - (global_of_constr functional))] - ((all_occurrences_expr, heq2), InHyp); - tclTHENS - (fun gls -> - let t_eq = compute_renamed_type gls (mkVar heq2) in - let def_id = - let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in - Nameops.out_name def_na - in - observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences - (mkVar heq2, - ExplicitBindings[dummy_loc,NamedHyp def_id, - f]) false) gls) - [tclTHENLIST - [observe_tac "list_rewrite" (list_rewrite true eqs); - cont_tac pmax le_proofs]; - tclTHENLIST[apply (delayed_force le_lt_SS); - compute_le_proofs le_proofs]]] - | arg::args -> - let v' = next_global_ident_away true v_id ids in - let ids = v'::ids in - let hex' = next_global_ident_away true hex_id ids in - let ids = hex'::ids in - let p' = next_global_ident_away true p_id ids in - let ids = p'::ids in - let new_pmax = next_global_ident_away true pmax_id ids in - let ids = pmax::ids in - let hle1 = next_global_ident_away true hle_id ids in - let ids = hle1::ids in - let hle2 = next_global_ident_away true hle_id ids in - let ids = hle2::ids in - let heq = next_global_ident_away true heq_id ids in - let ids = heq::ids in - let heq2 = next_global_ident_away true heq_id ids in - let ids = heq2::ids in - tclTHENLIST - [mkCaseEq(mkApp(termine, Array.of_list arg)); - h_intros [v'; hex']; - simplest_elim(mkVar hex'); - h_intros [p']; - simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; - mkVar p'|])); - h_intros [new_pmax;hle1;hle2]; - introduce_all_values_eq - (fun pmax' le_proofs'-> - tclTHENLIST - [cont_tac pmax' le_proofs'; - h_intros [heq;heq2]; - observe_tac ("rewriteRL " ^ (string_of_id heq2)) - (tclTRY (rewriteLR (mkVar heq2))); - tclTRY (tclTHENS - ( fun g -> - let t_eq = compute_renamed_type g (mkVar heq) in - let k_id,def_id = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in - Nameops.out_name k_na,Nameops.out_name def_na - in - let c_b = (mkVar heq, - ExplicitBindings - [dummy_loc, NamedHyp k_id, - f_S(mkVar pmax'); - dummy_loc, NamedHyp def_id, f]) - in - observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences - c_b false)) - g - ) - [tclIDTAC; - tclTHENLIST - [apply (delayed_force le_lt_n_Sm); - compute_le_proofs le_proofs']])]) - functional termine f p heq1 new_pmax - (p'::bounds)((mkVar pmax)::le_proofs) eqs - (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] - - -let rec_leaf_eq termine f ids functional eqs expr fn args = - let p = next_global_ident_away true p_id ids in - let ids = p::ids in - let v = next_global_ident_away true v_id ids in - let ids = v::ids in - let hex = next_global_ident_away true hex_id ids in - let ids = hex::ids in - let heq1 = next_global_ident_away true heq_id ids in - let ids = heq1::ids in - let hle1 = next_global_ident_away true hle_id ids in - let ids = hle1::ids in - tclTHENLIST - [observe_tac "intros v hex" (h_intros [v;hex]); - simplest_elim (mkVar hex); - h_intros [p;heq1]; - h_generalize [mkApp(delayed_force le_n,[|mkVar p|])]; - h_intros [hle1]; - observe_tac "introduce_all_values_eq" (introduce_all_values_eq - (fun _ _ -> tclIDTAC) - functional termine f p heq1 p [] [] eqs ids args); - observe_tac "failing here" (apply (delayed_force refl_equal))] - -let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) - (eqs:constr list) (expr:constr) = -(* tclTRY *) - (match kind_of_term expr with - Case(ci,t,a,l) -> - (match find_call_occs 0 f a with - _,[] -> - (fun g -> - let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in - tclTHENS - destruct_tac - (list_map_i - (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) true - (prove_eq termine f functional) - eqs ci.ci_cstr_nargs.(i)) - 0 (Array.to_list l)) g) - | _,_::_ -> - (match find_call_occs 0 f expr with - _,[] -> base_leaf_eq functional eqs f - | fn,args -> - fun g -> - let ids = ids_of_named_context (pf_hyps g) in - rec_leaf_eq termine f ids - (constr_of_global functional) - eqs expr fn args g)) - | _ -> - (match find_call_occs 0 f expr with - _,[] -> base_leaf_eq functional eqs f - | fn,args -> - fun g -> - let ids = ids_of_named_context (pf_hyps g) in - observe_tac "rec_leaf_eq" (rec_leaf_eq - termine f ids (constr_of_global functional) - eqs expr fn args) g));; - -let (com_eqn : identifier -> - global_reference -> global_reference -> global_reference - -> constr -> unit) = - fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> - let opacity = - match terminate_ref with - | ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end - | _ -> anomaly "terminate_lemma: not a constant" - in - let (evmap, env) = Command.get_current_context() in - let f_constr = (constr_of_global f_ref) in - let equation_lemma_type = subst1 f_constr equation_lemma_type in - (start_proof eq_name (Global, Proof Lemma) - (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); - by - (start_equation f_ref terminate_ref - (fun x -> - prove_eq - (constr_of_global terminate_ref) - f_constr - functional_ref - [] - (instantiate_lambda - (def_of_const (constr_of_global functional_ref)) - (f_constr::List.map mkVar x) - ) - ) - ); -(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) -(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () ->Command.save_named opacity) () ; -(* Pp.msgnl (str "eqn finished"); *) - - );; - -let nf_zeta env = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - env - Evd.empty - -let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : unit = - let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_named (function_name,None,function_type) (Global.env()) in -(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in -(* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *) - let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in - let res = -(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) -(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) - match kind_of_term eq' with - | App(e,[|_;_;eq_fix|]) -> - mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) - | _ -> failwith "Recursive Definition (res not eq)" - in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in - let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in - let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in - let equation_id = add_suffix function_name "_equation" in - let functional_id = add_suffix function_name "_F" in - let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Definition) res in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in - let relation = - interp_constr - Evd.empty - env_with_pre_rec_args - r - in - let tcc_lemma_name = add_suffix function_name "_tcc" in - let tcc_lemma_constr = ref None in -(* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ = - let term_ref = Nametab.locate (make_short_qualid term_id) in - let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in -(* message "start second proof"; *) - let stop = ref false in - begin - try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) - with e -> - begin - if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) - else anomaly "Cannot create equation Lemma" - ; -(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *) - stop := true; - end - end; - if not !stop - then - let eq_ref = Nametab.locate (make_short_qualid equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) - and eq_ref = destConst (constr_of_global eq_ref) in - generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; - if Flags.is_verbose () - then msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ - spc () ++ str"is defined" ) - ) - in - try - com_terminate - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - rec_arg_type - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - hook - with e -> - begin - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); -(* anomaly "Cannot create termination Lemma" *) - raise e - end - - - diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT deleted file mode 100644 index 23aeb6bb..00000000 --- a/contrib/interface/COPYRIGHT +++ /dev/null @@ -1,23 +0,0 @@ -(*****************************************************************************) -(* *) -(* Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq *) -(* *) -(* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *) -(* Copyright (C) 2006,2007 Lionel Elie Mamane *) -(* *) -(*****************************************************************************) - -The current directory contrib/interface implements Coq support for the -Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot -with contributions from Loïc Pottier and Laurence Rideau. - -Modifications by Lionel Elie Mamane <lionel@mamane.lu> for -generalising the protocol to suit other Coq interfaces. - -The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq) -is developed by the Lemme team at INRIA Sophia-Antipolis (see -http://www-sop.inria.fr/lemme) - -The files of the current directory are distributed under the terms of -the GNU Lesser General Public License Version 2.1. - diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli deleted file mode 100644 index 2eb2c381..00000000 --- a/contrib/interface/ascent.mli +++ /dev/null @@ -1,795 +0,0 @@ -type ct_AST = - CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT - | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING - | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE - | CT_astnode of ct_ID * ct_AST_LIST - | CT_astpath of ct_ID_LIST - | CT_astslam of ct_ID_OPT * ct_AST -and ct_AST_LIST = - CT_ast_list of ct_AST list -and ct_BINARY = - CT_binary of int -and ct_BINDER = - CT_coerce_DEF_to_BINDER of ct_DEF - | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA - | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA -and ct_BINDER_LIST = - CT_binder_list of ct_BINDER list -and ct_BINDER_NE_LIST = - CT_binder_ne_list of ct_BINDER * ct_BINDER list -and ct_BINDING = - CT_binding of ct_ID_OR_INT * ct_FORMULA -and ct_BINDING_LIST = - CT_binding_list of ct_BINDING list -and t_BOOL = - CT_false - | CT_true -and ct_CASE = - CT_case of string -and ct_CLAUSE = - CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT -and ct_COERCION_OPT = - CT_coerce_NONE_to_COERCION_OPT of ct_NONE - | CT_coercion_atm -and ct_COFIXTAC = - CT_cofixtac of ct_ID * ct_FORMULA -and ct_COFIX_REC = - CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA -and ct_COFIX_REC_LIST = - CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list -and ct_COFIX_TAC_LIST = - CT_cofix_tac_list of ct_COFIXTAC list -and ct_COMMAND = - CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST - | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD - | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN - | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL - | CT_abort of ct_ID_OPT_OR_ALL - | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST - | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT - | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_addpath of ct_STRING * ct_ID_OPT - | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST - | CT_bind_scope of ct_ID * ct_ID_NE_LIST - | CT_cd of ct_STRING_OPT - | CT_check of ct_FORMULA - | CT_class of ct_ID - | CT_close_scope of ct_ID - | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID - | CT_cofix_decl of ct_COFIX_REC_LIST - | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT - | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR - | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT - | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT - | CT_delim_scope of ct_ID * ct_ID - | CT_delpath of ct_STRING - | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE - | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID - | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE - | CT_explain_proof of ct_INT_LIST - | CT_explain_prooftree of ct_INT_LIST - | CT_export_id of ct_ID_NE_LIST - | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST - | CT_extraction of ct_ID_OPT - | CT_fix_decl of ct_FIX_REC_LIST - | CT_focus of ct_INT_OPT - | CT_go of ct_INT_OR_LOCN - | CT_guarded - | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_hint_extern of ct_INT * ct_FORMULA_OPT * ct_TACTIC_COM * ct_ID_LIST - | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM - | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST - | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_implicits of ct_ID * ct_ID_LIST_OPT - | CT_import_id of ct_ID_NE_LIST - | CT_ind_scheme of ct_SCHEME_SPEC_LIST - | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT - | CT_inline of ct_ID_NE_LIST - | CT_inspect of ct_INT - | CT_kill_node of ct_INT - | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING - | CT_local_close_scope of ct_ID - | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT - | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST - | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST - | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST - | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT - | CT_local_open_scope of ct_ID - | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST - | CT_locate of ct_ID - | CT_locate_file of ct_STRING - | CT_locate_lib of ct_ID - | CT_locate_notation of ct_STRING - | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST - | CT_ml_add_path of ct_STRING - | CT_ml_declare_modules of ct_STRING_NE_LIST - | CT_ml_print_modules - | CT_ml_print_path - | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR - | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT - | CT_no_inline of ct_ID_NE_LIST - | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE - | CT_open_scope of ct_ID - | CT_print - | CT_print_about of ct_ID - | CT_print_all - | CT_print_classes - | CT_print_ltac of ct_ID - | CT_print_coercions - | CT_print_grammar of ct_GRAMMAR - | CT_print_graph - | CT_print_hint of ct_ID_OPT - | CT_print_hintdb of ct_ID_OR_STAR - | CT_print_rewrite_hintdb of ct_ID - | CT_print_id of ct_ID - | CT_print_implicit of ct_ID - | CT_print_loadpath - | CT_print_module of ct_ID - | CT_print_module_type of ct_ID - | CT_print_modules - | CT_print_natural of ct_ID - | CT_print_natural_feature of ct_NATURAL_FEATURE - | CT_print_opaqueid of ct_ID - | CT_print_path of ct_ID * ct_ID - | CT_print_proof of ct_ID - | CT_print_setoids - | CT_print_scope of ct_ID - | CT_print_scopes - | CT_print_section of ct_ID - | CT_print_states - | CT_print_tables - | CT_print_universes of ct_STRING_OPT - | CT_print_visibility of ct_ID_OPT - | CT_proof of ct_FORMULA - | CT_proof_no_op - | CT_proof_with of ct_TACTIC_COM - | CT_pwd - | CT_quit - | CT_read_module of ct_ID - | CT_rec_ml_add_path of ct_STRING - | CT_recaddpath of ct_STRING * ct_ID_OPT - | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST - | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING - | CT_reserve of ct_ID_NE_LIST * ct_FORMULA - | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST - | CT_reset of ct_ID - | CT_reset_section of ct_ID - | CT_restart - | CT_restore_state of ct_ID - | CT_resume of ct_ID_OPT - | CT_save of ct_THM_OPT * ct_ID_OPT - | CT_scomments of ct_SCOMMENT_CONTENT_LIST - | CT_search of ct_ID * ct_IN_OR_OUT_MODULES - | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES - | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES - | CT_section_end of ct_ID - | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND - | CT_set_natural of ct_ID - | CT_set_natural_default - | CT_set_option of ct_TABLE - | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE - | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST - | CT_sethyp of ct_INT - | CT_setundo of ct_INT - | CT_show_existentials - | CT_show_goal of ct_INT_OPT - | CT_show_implicit of ct_INT - | CT_show_intro - | CT_show_intros - | CT_show_node - | CT_show_proof - | CT_show_proofs - | CT_show_script - | CT_show_tree - | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT - | CT_strategy of ct_LEVEL_LIST - | CT_suspend - | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT - | CT_tactic_definition of ct_TAC_DEF_NE_LIST - | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID - | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT - | CT_time of ct_COMMAND - | CT_undo of ct_INT_OPT - | CT_unfocus - | CT_unset_option of ct_TABLE - | CT_unsethyp - | CT_unsetundo - | CT_user_vernac of ct_ID * ct_VARG_LIST - | CT_variable of ct_VAR * ct_BINDER_NE_LIST - | CT_write_module of ct_ID * ct_STRING_OPT -and ct_LEVEL_LIST = - CT_level_list of (ct_LEVEL * ct_ID_LIST) list -and ct_LEVEL = - CT_Opaque - | CT_Level of ct_INT - | CT_Expand -and ct_COMMAND_LIST = - CT_command_list of ct_COMMAND * ct_COMMAND list -and ct_COMMENT = - CT_comment of string -and ct_COMMENT_S = - CT_comment_s of ct_COMMENT list -and ct_CONSTR = - CT_constr of ct_ID * ct_FORMULA - | CT_constr_coercion of ct_ID * ct_FORMULA -and ct_CONSTR_LIST = - CT_constr_list of ct_CONSTR list -and ct_CONTEXT_HYP_LIST = - CT_context_hyp_list of ct_PREMISE_PATTERN list -and ct_CONTEXT_PATTERN = - CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA - | CT_context of ct_ID_OPT * ct_FORMULA -and ct_CONTEXT_RULE = - CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM - | CT_def_context_rule of ct_TACTIC_COM -and ct_CONVERSION_FLAG = - CT_beta - | CT_delta - | CT_evar - | CT_iota - | CT_zeta -and ct_CONVERSION_FLAG_LIST = - CT_conversion_flag_list of ct_CONVERSION_FLAG list -and ct_CONV_SET = - CT_unf of ct_ID list - | CT_unfbut of ct_ID list -and ct_CO_IND = - CT_co_ind of string -and ct_DECL_NOTATION_OPT = - CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE - | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT -and ct_DEF = - CT_def of ct_ID_OPT * ct_FORMULA -and ct_DEFN = - CT_defn of string -and ct_DEFN_OR_THM = - CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN - | CT_coerce_THM_to_DEFN_OR_THM of ct_THM -and ct_DEF_BODY = - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN - | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD - | CT_type_of of ct_FORMULA -and ct_DEF_BODY_OPT = - CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY - | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT -and ct_DEP = - CT_dep of string -and ct_DESTRUCTING = - CT_coerce_NONE_to_DESTRUCTING of ct_NONE - | CT_destructing -and ct_DESTRUCT_LOCATION = - CT_conclusion_location - | CT_discardable_hypothesis - | CT_hypothesis_location -and ct_DOTDOT_OPT = - CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE - | CT_dotdot -and ct_EQN = - CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA -and ct_EQN_LIST = - CT_eqn_list of ct_EQN list -and ct_EVAL_CMD = - CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA -and ct_FIXTAC = - CT_fixtac of ct_ID * ct_INT * ct_FORMULA -and ct_FIX_BINDER = - CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC - | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA -and ct_FIX_BINDER_LIST = - CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list -and ct_FIX_REC = - CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT * - ct_FORMULA * ct_FORMULA -and ct_FIX_REC_LIST = - CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list -and ct_FIX_TAC_LIST = - CT_fix_tac_list of ct_FIXTAC list -and ct_FORMULA = - CT_coerce_BINARY_to_FORMULA of ct_BINARY - | CT_coerce_ID_to_FORMULA of ct_ID - | CT_coerce_NUM_to_FORMULA of ct_NUM - | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE - | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA - | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST - | CT_arrowc of ct_FORMULA * ct_FORMULA - | CT_bang of ct_FORMULA - | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST - | CT_cofixc of ct_ID * ct_COFIX_REC_LIST - | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST - | CT_existvarc - | CT_fixc of ct_ID * ct_FIX_BINDER_LIST - | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA - | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA - | CT_labelled_arg of ct_ID * ct_FORMULA - | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA - | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA - | CT_letin of ct_DEF * ct_FORMULA - | CT_notation of ct_STRING * ct_FORMULA_LIST - | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA - | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA - | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST -and ct_FORMULA_LIST = - CT_formula_list of ct_FORMULA list -and ct_FORMULA_NE_LIST = - CT_formula_ne_list of ct_FORMULA * ct_FORMULA list -and ct_FORMULA_OPT = - CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA - | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT -and ct_FORMULA_OR_INT = - CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA - | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT -and ct_GRAMMAR = - CT_grammar_none -and ct_HYP_LOCATION = - CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD - | CT_intype of ct_ID * ct_INT_LIST - | CT_invalue of ct_ID * ct_INT_LIST -and ct_HYP_LOCATION_LIST_OR_STAR = - CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR - | CT_hyp_location_list of ct_HYP_LOCATION list -and ct_ID = - CT_ident of string - | CT_metac of ct_INT - | CT_metaid of string -and ct_IDENTITY_OPT = - CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE - | CT_identity -and ct_ID_LIST = - CT_id_list of ct_ID list -and ct_ID_LIST_LIST = - CT_id_list_list of ct_ID_LIST list -and ct_ID_LIST_OPT = - CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST - | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE -and ct_ID_NE_LIST = - CT_id_ne_list of ct_ID * ct_ID list -and ct_ID_NE_LIST_OR_STAR = - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST - | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR -and ct_ID_NE_LIST_OR_STRING = - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST - | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING -and ct_ID_OPT = - CT_coerce_ID_to_ID_OPT of ct_ID - | CT_coerce_NONE_to_ID_OPT of ct_NONE -and ct_ID_OPT_LIST = - CT_id_opt_list of ct_ID_OPT list -and ct_ID_OPT_NE_LIST = - CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list -and ct_ID_OPT_OR_ALL = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT - | CT_all -and ct_ID_OR_INT = - CT_coerce_ID_to_ID_OR_INT of ct_ID - | CT_coerce_INT_to_ID_OR_INT of ct_INT -and ct_ID_OR_INT_OPT = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT - | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT - | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT -and ct_ID_OR_STAR = - CT_coerce_ID_to_ID_OR_STAR of ct_ID - | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR -and ct_ID_OR_STRING = - CT_coerce_ID_to_ID_OR_STRING of ct_ID - | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING -and ct_ID_OR_STRING_NE_LIST = - CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list -and ct_IMPEXP = - CT_coerce_NONE_to_IMPEXP of ct_NONE - | CT_export - | CT_import -and ct_IND_SPEC = - CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT -and ct_IND_SPEC_LIST = - CT_ind_spec_list of ct_IND_SPEC list -and ct_INT = - CT_int of int -and ct_INTRO_PATT = - CT_coerce_ID_to_INTRO_PATT of ct_ID - | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list -and ct_INTRO_PATT_LIST = - CT_intro_patt_list of ct_INTRO_PATT list -and ct_INTRO_PATT_OPT = - CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT - | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT -and ct_INT_LIST = - CT_int_list of ct_INT list -and ct_INT_NE_LIST = - CT_int_ne_list of ct_INT * ct_INT list -and ct_INT_OPT = - CT_coerce_INT_to_INT_OPT of ct_INT - | CT_coerce_NONE_to_INT_OPT of ct_NONE -and ct_INT_OR_LOCN = - CT_coerce_INT_to_INT_OR_LOCN of ct_INT - | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN -and ct_INT_OR_NEXT = - CT_coerce_INT_to_INT_OR_NEXT of ct_INT - | CT_next_level -and ct_INV_TYPE = - CT_inv_clear - | CT_inv_regular - | CT_inv_simple -and ct_IN_OR_OUT_MODULES = - CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE - | CT_in_modules of ct_ID_NE_LIST - | CT_out_modules of ct_ID_NE_LIST -and ct_LET_CLAUSE = - CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE -and ct_LET_CLAUSES = - CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list -and ct_LET_VALUE = - CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY - | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM -and ct_LOCAL_OPT = - CT_coerce_NONE_to_LOCAL_OPT of ct_NONE - | CT_local -and ct_LOCN = - CT_locn of string -and ct_MATCHED_FORMULA = - CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA - | CT_formula_as of ct_FORMULA * ct_ID_OPT - | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA - | CT_formula_in of ct_FORMULA * ct_FORMULA -and ct_MATCHED_FORMULA_NE_LIST = - CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list -and ct_MATCH_PATTERN = - CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT - | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM - | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST - | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT - | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN - | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST -and ct_MATCH_PATTERN_LIST = - CT_match_pattern_list of ct_MATCH_PATTERN list -and ct_MATCH_PATTERN_NE_LIST = - CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list -and ct_MATCH_TAC_RULE = - CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE -and ct_MATCH_TAC_RULES = - CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list -and ct_MODIFIER = - CT_entry_type of ct_ID * ct_ID - | CT_format of ct_STRING - | CT_lefta - | CT_nona - | CT_only_parsing - | CT_righta - | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT - | CT_set_level of ct_INT -and ct_MODIFIER_LIST = - CT_modifier_list of ct_MODIFIER list -and ct_MODULE_BINDER = - CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE -and ct_MODULE_BINDER_LIST = - CT_module_binder_list of ct_MODULE_BINDER list -and ct_MODULE_EXPR = - CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT - | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR -and ct_MODULE_TYPE = - CT_coerce_ID_to_MODULE_TYPE of ct_ID - | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID_LIST * ct_FORMULA - | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID_LIST * ct_ID -and ct_MODULE_TYPE_CHECK = - CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT - | CT_only_check of ct_MODULE_TYPE -and ct_MODULE_TYPE_OPT = - CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT - | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE -and ct_NATURAL_FEATURE = - CT_contractible - | CT_implicit - | CT_nat_transparent -and ct_NONE = - CT_none -and ct_NUM = - CT_int_encapsulator of string -and ct_NUM_TYPE = - CT_num_type of string -and ct_OMEGA_FEATURE = - CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING - | CT_flag_action - | CT_flag_system - | CT_flag_time -and ct_OMEGA_MODE = - CT_set - | CT_switch - | CT_unset -and ct_ORIENTATION = - CT_lr - | CT_rl -and ct_PATTERN = - CT_pattern_occ of ct_INT_LIST * ct_FORMULA -and ct_PATTERN_NE_LIST = - CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list -and ct_PATTERN_OPT = - CT_coerce_NONE_to_PATTERN_OPT of ct_NONE - | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN -and ct_PREMISE = - CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA - | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA - | CT_premise of ct_ID * ct_FORMULA -and ct_PREMISES_LIST = - CT_premises_list of ct_PREMISE list -and ct_PREMISE_PATTERN = - CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN -and ct_PROOF_SCRIPT = - CT_proof_script of ct_COMMAND list -and ct_RECCONSTR = - CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT - | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT - | CT_recconstr of ct_ID_OPT * ct_FORMULA - | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA -and ct_RECCONSTR_LIST = - CT_recconstr_list of ct_RECCONSTR list -and ct_REC_TACTIC_FUN = - CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM -and ct_REC_TACTIC_FUN_LIST = - CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list -and ct_RED_COM = - CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET - | CT_fold of ct_FORMULA_LIST - | CT_hnf - | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET - | CT_pattern of ct_PATTERN_NE_LIST - | CT_red - | CT_cbvvm - | CT_simpl of ct_PATTERN_OPT - | CT_unfold of ct_UNFOLD_NE_LIST -and ct_RETURN_INFO = - CT_coerce_NONE_to_RETURN_INFO of ct_NONE - | CT_as_and_return of ct_ID_OPT * ct_FORMULA - | CT_return of ct_FORMULA -and ct_RULE = - CT_rule of ct_PREMISES_LIST * ct_FORMULA -and ct_RULE_LIST = - CT_rule_list of ct_RULE list -and ct_SCHEME_SPEC = - CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE -and ct_SCHEME_SPEC_LIST = - CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list -and ct_SCOMMENT_CONTENT = - CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA - | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING -and ct_SCOMMENT_CONTENT_LIST = - CT_scomment_content_list of ct_SCOMMENT_CONTENT list -and ct_SECTION_BEGIN = - CT_section of ct_ID -and ct_SECTION_BODY = - CT_section_body of ct_COMMAND list -and ct_SIGNED_INT = - CT_coerce_INT_to_SIGNED_INT of ct_INT - | CT_minus of ct_INT -and ct_SIGNED_INT_LIST = - CT_signed_int_list of ct_SIGNED_INT list -and ct_SINGLE_OPTION_VALUE = - CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT - | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING -and ct_SORT_TYPE = - CT_sortc of string -and ct_SPEC_LIST = - CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST - | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST -and ct_SPEC_OPT = - CT_coerce_NONE_to_SPEC_OPT of ct_NONE - | CT_spec -and ct_STAR = - CT_star -and ct_STAR_OPT = - CT_coerce_NONE_to_STAR_OPT of ct_NONE - | CT_coerce_STAR_to_STAR_OPT of ct_STAR -and ct_STRING = - CT_string of string -and ct_STRING_NE_LIST = - CT_string_ne_list of ct_STRING * ct_STRING list -and ct_STRING_OPT = - CT_coerce_NONE_to_STRING_OPT of ct_NONE - | CT_coerce_STRING_to_STRING_OPT of ct_STRING -and ct_TABLE = - CT_coerce_ID_to_TABLE of ct_ID - | CT_table of ct_ID * ct_ID -and ct_TACTIC_ARG = - CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD - | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT - | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM - | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE - | CT_void -and ct_TACTIC_ARG_LIST = - CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list -and ct_TACTIC_COM = - CT_abstract of ct_ID_OPT * ct_TACTIC_COM - | CT_absurd of ct_FORMULA - | CT_any_constructor of ct_TACTIC_OPT - | CT_apply of ct_FORMULA * ct_SPEC_LIST - | CT_assert of ct_ID_OPT * ct_FORMULA - | CT_assumption - | CT_auto of ct_INT_OPT - | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR - | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT - | CT_autotdb of ct_INT_OPT - | CT_case_type of ct_FORMULA - | CT_casetac of ct_FORMULA * ct_SPEC_LIST - | CT_cdhyp of ct_ID - | CT_change of ct_FORMULA * ct_CLAUSE - | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE - | CT_clear of ct_ID_NE_LIST - | CT_clear_body of ct_ID_NE_LIST - | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST - | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_constructor of ct_INT * ct_SPEC_LIST - | CT_contradiction - | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST - | CT_cut of ct_FORMULA - | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT - | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT - | CT_dauto of ct_INT_OPT * ct_INT_OPT - | CT_dconcl - | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA - | CT_decompose_record of ct_FORMULA - | CT_decompose_sum of ct_FORMULA - | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT - | CT_deprewrite_lr of ct_ID - | CT_deprewrite_rl of ct_ID - | CT_destruct of ct_ID_OR_INT - | CT_dhyp of ct_ID - | CT_discriminate_eq of ct_ID_OR_INT_OPT - | CT_do of ct_ID_OR_INT * ct_TACTIC_COM - | CT_eapply of ct_FORMULA * ct_SPEC_LIST - | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT - | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR - | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING - | CT_elim_type of ct_FORMULA - | CT_exact of ct_FORMULA - | CT_exact_no_check of ct_FORMULA - | CT_vm_cast_no_check of ct_FORMULA - | CT_exists of ct_SPEC_LIST - | CT_fail of ct_ID_OR_INT * ct_STRING_OPT - | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_firstorder of ct_TACTIC_OPT - | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST - | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST - | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST - | CT_formula_marker of ct_FORMULA - | CT_fresh of ct_STRING_OPT - | CT_generalize of ct_FORMULA_NE_LIST - | CT_generalize_dependent of ct_FORMULA - | CT_idtac of ct_STRING_OPT - | CT_induction of ct_ID_OR_INT - | CT_info of ct_TACTIC_COM - | CT_injection_eq of ct_ID_OR_INT_OPT - | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE - | CT_intro of ct_ID_OPT - | CT_intro_after of ct_ID_OPT * ct_ID - | CT_intros of ct_INTRO_PATT_LIST - | CT_intros_until of ct_ID_OR_INT - | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST - | CT_left of ct_SPEC_LIST - | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE - | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE - | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list - | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list - | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES - | CT_move_after of ct_ID * ct_ID - | CT_new_destruct of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT - | CT_new_induction of ct_FORMULA_OR_INT list * ct_USING * ct_INTRO_PATT_OPT - | CT_omega - | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM - | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_pose of ct_ID_OPT * ct_FORMULA - | CT_progress of ct_TACTIC_COM - | CT_prolog of ct_FORMULA_LIST * ct_INT - | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM - | CT_reduce of ct_RED_COM * ct_CLAUSE - | CT_refine of ct_FORMULA - | CT_reflexivity - | CT_rename of ct_ID * ct_ID - | CT_repeat of ct_TACTIC_COM - | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT - | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE - | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE - | CT_right of ct_SPEC_LIST - | CT_ring of ct_FORMULA_LIST - | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST - | CT_simplify_eq of ct_ID_OR_INT_OPT - | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST - | CT_split of ct_SPEC_LIST - | CT_subst of ct_ID_LIST - | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB - | CT_symmetry of ct_CLAUSE - | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT - | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM - | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list - | CT_transitivity of ct_FORMULA - | CT_trivial - | CT_trivial_with of ct_ID_NE_LIST_OR_STAR - | CT_truecut of ct_ID_OPT * ct_FORMULA - | CT_try of ct_TACTIC_COM - | CT_use of ct_FORMULA - | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST - | CT_user_tac of ct_ID * ct_TARG_LIST -and ct_TACTIC_OPT = - CT_coerce_NONE_to_TACTIC_OPT of ct_NONE - | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM -and ct_TAC_DEF = - CT_tac_def of ct_ID * ct_TACTIC_COM -and ct_TAC_DEF_NE_LIST = - CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list -and ct_TARG = - CT_coerce_BINDING_to_TARG of ct_BINDING - | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC - | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC - | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT - | CT_coerce_PATTERN_to_TARG of ct_PATTERN - | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT - | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST - | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE - | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST - | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM - | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST - | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD - | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST -and ct_TARG_LIST = - CT_targ_list of ct_TARG list -and ct_TERM_CHANGE = - CT_check_term of ct_FORMULA - | CT_inst_term of ct_ID * ct_FORMULA -and ct_TEXT = - CT_coerce_ID_to_TEXT of ct_ID - | CT_text_formula of ct_FORMULA - | CT_text_h of ct_TEXT list - | CT_text_hv of ct_TEXT list - | CT_text_op of ct_TEXT list - | CT_text_path of ct_SIGNED_INT_LIST - | CT_text_v of ct_TEXT list -and ct_THEOREM_GOAL = - CT_goal of ct_FORMULA - | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA -and ct_THM = - CT_thm of string -and ct_THM_OPT = - CT_coerce_NONE_to_THM_OPT of ct_NONE - | CT_coerce_THM_to_THM_OPT of ct_THM -and ct_TYPED_FORMULA = - CT_typed_formula of ct_FORMULA * ct_FORMULA -and ct_UNFOLD = - CT_coerce_ID_to_UNFOLD of ct_ID - | CT_unfold_occ of ct_ID * ct_INT_NE_LIST -and ct_UNFOLD_NE_LIST = - CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list -and ct_USING = - CT_coerce_NONE_to_USING of ct_NONE - | CT_using of ct_FORMULA * ct_SPEC_LIST -and ct_USINGTDB = - CT_coerce_NONE_to_USINGTDB of ct_NONE - | CT_usingtdb -and ct_VAR = - CT_var of string -and ct_VARG = - CT_coerce_AST_to_VARG of ct_AST - | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST - | CT_coerce_BINDER_to_VARG of ct_BINDER - | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST - | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST - | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST - | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT - | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT - | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL - | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT - | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST - | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT - | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT - | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT - | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST -and ct_VARG_LIST = - CT_varg_list of ct_VARG list -and ct_VERBOSE_OPT = - CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE - | CT_verbose -;; diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml deleted file mode 100644 index 483453cb..00000000 --- a/contrib/interface/blast.ml +++ /dev/null @@ -1,627 +0,0 @@ -(* Une tactique qui tente de démontrer toute seule le but courant, - interruptible par pcoq (si dans le fichier C:\WINDOWS\free il y a un A) -*) -open Termops;; -open Nameops;; -open Auto;; -open Clenv;; -open Command;; -open Declarations;; -open Declare;; -open Eauto;; -open Environ;; -open Equality;; -open Evd;; -open Hipattern;; -open Inductive;; -open Names;; -open Pattern;; -open Pbp;; -open Pfedit;; -open Pp;; -open Printer -open Proof_trees;; -open Proof_type;; -open Rawterm;; -open Reduction;; -open Refiner;; -open Sign;; -open String;; -open Tacmach;; -open Tacred;; -open Tacticals;; -open Tactics;; -open Term;; -open Typing;; -open Util;; -open Vernacentries;; -open Vernacinterp;; - - -let parse_com = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_tac t = - try (Pcoq.parse_string Pcoq.Tactic.tactic t) - with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t)); - failwith "tactic") -;; - -let is_free () = - let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in - let c=input_char st in - close_in st; - c = 'A' -;; - -(* marche pas *) -(* -let is_free () = - msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]); - let s = Stream.of_channel stdin in - msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]); - try (Stream.empty s; - msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]); - true) - with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]); - false) -;; -*) -let free_try tac g = - if is_free() - then (tac g) - else (failwith "not free") -;; -let adrel (x,t) e = - match x with - Name(xid) -> Environ.push_rel (x,None,t) e - | Anonymous -> Environ.push_rel (x,None,t) e -(* les constantes ayant une définition apparaissant dans x *) -let rec def_const_in_term_rec vl x = - match (kind_of_term x) with - Prod(n,t,c)-> - let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c - | Lambda(n,t,c) -> - let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c - | App(f,args) -> def_const_in_term_rec vl f - | Sort(Prop(Null)) -> Prop(Null) - | Sort(c) -> c - | Ind(ind) -> - let (mib, mip) = Global.lookup_inductive ind in - new_sort_in_family (inductive_sort_family mip) - | Construct(c) -> - def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) - -> def_const_in_term_rec vl x - | Cast(x,_,t)-> def_const_in_term_rec vl t - | Const(c) -> def_const_in_term_rec vl (Typeops.type_of_constant vl c) - | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x) -;; -let def_const_in_term_ x = - def_const_in_term_rec (Global.env()) (strip_outer_cast x) -;; -(************************************************************************* - recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli - modif de print_info_script avec pr_bar -*) - -let pr_bar () = str "|" - -let rec print_info_script sigma osign pf = - let {evar_hyps=sign; evar_concl=cl} = pf.goal in - match pf.ref with - | None -> (mt ()) - | Some(r,spfl) -> - Tactic_printer.pr_rule r ++ - match spfl with - | [] -> - (str " " ++ fnl()) - | [pf1] -> - if pf1.ref = None then - (str " " ++ fnl()) - else - (str";" ++ brk(1,3) ++ - print_info_script sigma sign pf1) - | _ -> ( str";[" ++ fnl() ++ - prlist_with_sep pr_bar - (print_info_script sigma sign) spfl ++ - str"]") - -let format_print_info_script sigma osign pf = - hov 0 (print_info_script sigma osign pf) - -let print_subscript sigma sign pf = - (* if is_tactic_proof pf then - format_print_info_script sigma sign (subproof_of_proof pf) - else *) - format_print_info_script sigma sign pf -(****************) - -let pp_string x = - msgnl_with Format.str_formatter x; - Format.flush_str_formatter () -;; - -(*********************************************************************** - copié de tactics/eauto.ml -*) - -(***************************************************************************) -(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) -(***************************************************************************) - -let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) - -let unify_e_resolve (c,clenv) gls = - let clenv' = connect_clenv gls clenv in - let _ = clenv_unique_resolver false clenv' gls in - Hiddentac.h_simplest_eapply c gls - -let rec e_trivial_fail_db db_list local_db goal = - let tacl = - registered_e_assumption :: - (tclTHEN Tactics.intro - (function g'-> - let d = pf_last_hyp g' in - let hintl = make_resolve_hyp (pf_env g') (project g') d in - (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: - (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal - -and e_my_find_search db_list local_db hdc concl = - let hdc = head_of_constr_reference hdc in - let hintl = - if occur_existential concl then - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, ({pri=b; pat = p; code=t} as _patac)) -> - (b, - let tac = - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (term,cl) -> unify_e_resolve (term,cl) - | Give_exact (c) -> e_give_exact_constr c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> Auto.conclPattern concl p tacast - in - (free_try tac,pr_autotactic t)) - (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); - try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); - raise e) - i*) - in - List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) - with Bound | Not_found -> [] - -let e_possible_resolve db_list local_db gl = - try List.map snd (e_my_find_search db_list local_db - (fst (head_constr_bound gl)) gl) - with Bound | Not_found -> [] - -let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) - -let find_first_goal gls = - try first_goal gls with UserError _ -> assert false - -(*s The following module [SearchProblem] is used to instantiate the generic - exploration functor [Explore.Make]. *) - -module MySearchProblem = struct - - type state = { - depth : int; (*r depth of search before failing *) - tacres : goal list sigma * validation; - last_tactic : std_ppcmds; - dblist : Auto.hint_db list; - localdb : Auto.hint_db list } - - let success s = (sig_it (fst s.tacres)) = [] - - let rec filter_tactics (glls,v) = function - | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in - let v' p = v (ptl p) in - ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl - with e when Logic.catchable_exception e -> - filter_tactics (glls,v) tacl - - (* Ordering of states is lexicographic on depth (greatest first) then - number of remaining goals. *) - let compare s s' = - let d = s'.depth - s.depth in - let nbgoals s = List.length (sig_it (fst s.tacres)) in - if d <> 0 then d else nbgoals s - nbgoals s' - - let branching s = - if s.depth = 0 then - [] - else - let lg = fst s.tacres in - let nbgl = List.length (sig_it lg) in - assert (nbgl > 0); - let g = find_first_goal lg in - let assumption_tacs = - let l = - filter_tactics s.tacres - (List.map - (fun id -> (e_give_exact_constr (mkVar id), - (str "Exact" ++ spc()++ pr_id id))) - (pf_ids_of_hyps g)) - in - List.map (fun (res,pp) -> { depth = s.depth; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb }) l - in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in - let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb }) - (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) - in - let rec_tacs = - let l = - filter_tactics s.tacres - (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) - in - List.map - (fun ((lgls,_) as res, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; tacres = res; last_tactic = pp; - dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; - dblist = s.dblist; last_tactic = pp; - localdb = - list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) - l - in - List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - - let pp s = - msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ - s.last_tactic ++ str "\n")) - -end - -module MySearch = Explore.Make(MySearchProblem) - -let make_initial_state n gl dblist localdb = - { MySearchProblem.depth = n; - MySearchProblem.tacres = tclIDTAC gl; - MySearchProblem.last_tactic = (mt ()); - MySearchProblem.dblist = dblist; - MySearchProblem.localdb = [localdb] } - -let e_depth_search debug p db_list local_db gl = - try - let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in - let s = tac (make_initial_state p gl db_list local_db) in - s.MySearchProblem.tacres - with Not_found -> error "EAuto: depth first search failed" - -let e_breadth_search debug n db_list local_db gl = - try - let tac = - if debug then MySearch.debug_breadth_first else MySearch.breadth_first - in - let s = tac (make_initial_state n gl db_list local_db) in - s.MySearchProblem.tacres - with Not_found -> error "EAuto: breadth first search failed" - -let e_search_auto debug (n,p) db_list gl = - let local_db = make_local_hint_db true [] gl in - if n = 0 then - e_depth_search debug p db_list local_db gl - else - e_breadth_search debug n db_list local_db gl - -let eauto debug np dbnames = - let db_list = - List.map - (fun x -> - try searchtable_map x - with Not_found -> error ("EAuto: "^x^": No such Hint database")) - ("core"::dbnames) - in - tclTRY (e_search_auto debug np db_list) - -let full_eauto debug n gl = - let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map searchtable_map dbnames in - let _local_db = make_local_hint_db true [] gl in - tclTRY (e_search_auto debug n db_list) gl - -let my_full_eauto n gl = full_eauto false (n,0) gl - -(********************************************************************** - copié de tactics/auto.ml on a juste modifié search_gen -*) - -(* local_db is a Hint database containing the hypotheses of current goal *) -(* Papageno : cette fonction a été pas mal simplifiée depuis que la base - de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) - -let rec trivial_fail_db db_list local_db gl = - let intro_tac = - tclTHEN intro - (fun g'-> - let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') - in - tclFIRST - (assumption::intro_tac:: - (List.map tclCOMPLETE - (trivial_resolve db_list local_db (pf_concl gl)))) gl - -and my_find_search db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> - let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in - List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - List.map - (fun (st, {pri=b; pat=p; code=t} as _patac) -> - (b, - match t with - | Res_pf (term,cl) -> unify_resolve st (term,cl) - | ERes_pf (_,c) -> (fun gl -> error "eres_pf") - | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve st (term,cl)) - (trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_in_concl [all_occurrences,c] - | Extern tacast -> conclPattern concl p tacast)) - tacl - -and trivial_resolve db_list local_db cl = - try - let hdconstr = fst (head_constr_bound cl) in - priority - (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> - [] - -(**************************************************************************) -(* The classical Auto tactic *) -(**************************************************************************) - -let possible_resolve db_list local_db cl = - try - let hdconstr = fst (head_constr_bound cl) in - List.map snd - (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> - [] - -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let t = head_constr typc in - if Hipattern.is_conjunction (applist t) then - simplest_case c gls - else - errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") - -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls - else - errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") - - -(* decomp is an natural number giving an indication on decomposition - of conjunction in hypotheses, 0 corresponds to no decomposition *) -(* n is the max depth of search *) -(* local_db contains the local Hypotheses *) - -let rec search_gen decomp n db_list local_db extra_sign goal = - if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> - (tclTRY_sign decomp_empty_term extra_sign) - :: - (List.map - (fun id -> tclTHEN (decomp_unary_term (mkVar id)) - (tclTHEN - (clear [id]) - (free_try (search_gen decomp p db_list local_db [])))) - (pf_ids_of_hyps goal)) - in - let intro_tac = - tclTHEN intro - (fun g' -> - let (hid,_,htyp as d) = pf_last_hyp g' in - let hintl = - try - [make_apply_entry (pf_env g') (project g') - (true,true,false) - None - (mkVar hid,htyp)] - with Failure _ -> [] - in - (free_try - (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d]) - g')) - in - let rec_tacs = - List.map - (fun ntac -> - tclTHEN ntac - (free_try - (search_gen decomp (n-1) db_list local_db empty_named_context))) - (possible_resolve db_list local_db (pf_concl goal)) - in - tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal - - -let search = search_gen 0 - -let default_search_depth = ref 5 - -let full_auto n gl = - let dbnames = current_db_names () in - let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map searchtable_map dbnames in - let hyps = pf_hyps gl in - tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl - -let default_full_auto gl = full_auto !default_search_depth gl -(************************************************************************) - -let blast_tactic = ref (free_try default_full_auto) -;; - -let blast_auto = (free_try default_full_auto) -(* (tclTHEN (free_try default_full_auto) - (free_try (my_full_eauto 2))) -*) -;; -let blast_simpl = (free_try (reduce (Simpl None) onConcl)) -;; -let blast_induction1 = - (free_try (tclTHEN (tclTRY intro) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; -let blast_induction2 = - (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; -let blast_induction3 = - (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) - (tclTRY (tclLAST_HYP simplest_elim)))) -;; - -blast_tactic := - (tclORELSE (tclCOMPLETE blast_auto) - (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto)) - (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1 - (tclTHEN blast_simpl blast_auto))) - (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2 - (tclTHEN blast_simpl blast_auto))) - (tclCOMPLETE (tclTHEN blast_induction3 - (tclTHEN blast_simpl blast_auto))))))) -;; -(* -blast_tactic := (tclTHEN (free_try default_full_auto) - (free_try (my_full_eauto 4))) -;; -*) - -let vire_extvar s = - let interro = ref false in - let interro_pos = ref 0 in - for i=0 to (length s)-1 do - if get s i = '?' - then (interro := true; - interro_pos := i) - else if (!interro && - (List.mem (get s i) - ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) - then set s i ' ' - else interro:=false - done; - s -;; - -let blast gls = - let leaf g = { - open_subgoals = 1; - goal = g; - ref = None } in - try (let (sgl,v) as _res = !blast_tactic gls in - let {it=lg} = sgl in - if lg = [] - then (let pf = v (List.map leaf (sig_it sgl)) in - let sign = (sig_it gls).evar_hyps in - let x = print_subscript - (sig_sig gls) sign pf in - msgnl (hov 0 (str"Blast ==> " ++ x)); - let x = print_subscript - (sig_sig gls) sign pf in - let tac_string = - pp_string (hov 0 x ) in - (* on remplace les ?1 ?2 ... de refine par ? *) - parse_tac ((vire_extvar tac_string) - ^ ".") - ) - else (msgnl (hov 0 (str"Blast failed to prove the goal...")); - failwith "echec de blast")) - with _ -> failwith "echec de blast" -;; - -let blast_tac display_function = function - | (n::_) as _l -> - (function g -> - let exp_ast = (blast g) in - (display_function exp_ast; - tclIDTAC g)) - | _ -> failwith "expecting other arguments";; - -let blast_tac_txt = - blast_tac - (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));; - -(* Obsolète ? -overwriting_add_tactic "Blast1" blast_tac_txt;; -*) - -(* -Grammar tactic ne_numarg_list : list := - ne_numarg_single [numarg($n)] ->[$n] -| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ]. -Grammar tactic simple_tactic : ast := - blast1 [ "Blast1" ne_numarg_list($ns) ] -> - [ (Blast1 ($LIST $ns)) ]. - - - -PATH=/usr/local/bin:/usr/bin:$PATH -COQTOP=d:/Tools/coq-7.0-3mai -CAMLLIB=/usr/local/lib/ocaml -CAMLP4LIB=/usr/local/lib/camlp4 -export CAMLLIB -export COQTOP -export CAMLP4LIB -d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe -Drop. -#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; -*) diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli deleted file mode 100644 index f6701943..00000000 --- a/contrib/interface/blast.mli +++ /dev/null @@ -1,3 +0,0 @@ -val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - int list -> Proof_type.tactic - diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 deleted file mode 100644 index 51dce4f7..00000000 --- a/contrib/interface/centaur.ml4 +++ /dev/null @@ -1,885 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* - * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu> - * to implement the following features - * - Terms (optionally) as pretty-printed string and not trees - * - (Optionally) give most commands their usual Coq semantics - * - Add the backtracking information to the status message. - * in the following time period - * - May-November 2006 - * and - * - Make use of new Command.save_hook to generate dependencies at - * save-time. - * in - * - June 2007 - *) - -(*Toplevel loop for the communication between Coq and Centaur *) -open Names;; -open Nameops;; -open Util;; -open Term;; -open Pp;; -open Ppconstr;; -open Prettyp;; -open Libnames;; -open Libobject;; -open Library;; -open Vernacinterp;; -open Evd;; -open Proof_trees;; -open Tacmach;; -open Pfedit;; -open Proof_type;; -open Parsing;; -open Environ;; -open Declare;; -open Declarations;; -open Rawterm;; -open Reduction;; -open Classops;; -open Vernacinterp;; -open Vernac;; -open Command;; -open Protectedtoplevel;; -open Line_oriented_parser;; -open Xlate;; -open Vtp;; -open Ascent;; -open Translate;; -open Name_to_ast;; -open Pbp;; -open Blast;; -(* open Dad;; *) -open Debug_tac;; -open Search;; -open Constrintern;; -open Nametab;; -open Showproof;; -open Showproof_ct;; -open Tacexpr;; -open Vernacexpr;; -open Printer;; - -let pcoq_started = ref None;; - -let if_pcoq f a = - if !pcoq_started <> None then f a else error "Pcoq is not started";; - -let text_proof_flag = ref "en";; - -let pcoq_history = ref true;; - -let assert_pcoq_history f a = - if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";; - -let current_proof_name () = - try - string_of_id (get_current_proof_name ()) - with - UserError("Pfedit.get_proof", _) -> "";; - -let current_goal_index = ref 0;; - -let guarded_force_eval_stream (s : std_ppcmds) = - let l = ref [] in - let f elt = l:= elt :: !l in - (try Stream.iter f s with - | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); - Stream.of_list (List.rev !l);; - - -let rec string_of_path p = - match p with [] -> "\n" - | i::p -> (string_of_int i)^" "^ (string_of_path p) -;; -let print_path p = - output_results_nl (str "Path:" ++ str (string_of_path p)) -;; - -let kill_proof_node index = - let paths = History.historical_undo (current_proof_name()) index in - let _ = List.iter - (fun path -> (traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - traverse_to [])) - paths in - History.border_length (current_proof_name());; - - -type vtp_tree = - | P_rl of ct_RULE_LIST - | P_r of ct_RULE - | P_s_int of ct_SIGNED_INT_LIST - | P_pl of ct_PREMISES_LIST - | P_cl of ct_COMMAND_LIST - | P_t of ct_TACTIC_COM - | P_text of ct_TEXT - | P_ids of ct_ID_LIST;; - -let print_tree t = - (match t with - | P_rl x -> fRULE_LIST x - | P_r x -> fRULE x - | P_s_int x -> fSIGNED_INT_LIST x - | P_pl x -> fPREMISES_LIST x - | P_cl x -> fCOMMAND_LIST x - | P_t x -> fTACTIC_COM x - | P_text x -> fTEXT x - | P_ids x -> fID_LIST x) - ++ (str "e\nblabla\n");; - - -(*Message functions, the text of these messages is recognized by the protocols *) -(*of CtCoq *) -let ctf_header message_name request_id = - str "message" ++ fnl() ++ str message_name ++ fnl() ++ - int request_id ++ fnl();; - -let ctf_acknowledge_command request_id command_count opt_exn = - let goal_count, goal_index = - if refining() then - let g_count = - List.length - (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in - g_count, !current_goal_index - else - (0, 0) - and statnum = Lib.current_command_label () - and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0 - and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in - (ctf_header "acknowledge" request_id ++ - int command_count ++ fnl() ++ - int goal_count ++ fnl () ++ - int goal_index ++ fnl () ++ - str (current_proof_name()) ++ fnl() ++ - int statnum ++ fnl() ++ - print_tree (P_ids pending) ++ - int dpth ++ fnl() ++ - (match opt_exn with - Some e -> Cerrors.explain_exn e - | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; - -let ctf_undoResults = ctf_header "undo_results";; - -let ctf_TextMessage = ctf_header "text_proof";; - -let ctf_SearchResults = ctf_header "search_results";; - -let ctf_OtherGoal = ctf_header "other_goal";; - -let ctf_Location = ctf_header "location";; - -let ctf_StateMessage = ctf_header "state";; - -let ctf_PathGoalMessage () = - fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();; - -let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; - -let ctf_GoalsReqIdMessage = ctf_header "goals_state";; - -let ctf_NewStateMessage = ctf_header "fresh_state";; - -let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ - str "saved" ++ fnl();; - -let ctf_KilledMessage req_id ngoals = - ctf_header "killed" req_id ++ int ngoals ++ fnl ();; - -let ctf_AbortedAllMessage () = - fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; - -let ctf_AbortedMessage request_id na = - ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; - -let ctf_UserErrorMessage request_id stream = - let stream = guarded_force_eval_stream stream in - ctf_header "user_error" request_id ++ stream ++ fnl() ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - -let ctf_ResetInitialMessage () = - fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();; - -let ctf_ResetIdentMessage request_id s = - ctf_header "reset_ident" request_id ++ str s ++ fnl () ++ - str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - - -let break_happened = ref false;; - -let output_results stream vtp_tree = - let _ = Sys.signal Sys.sigint - (Sys.Signal_handle(fun i -> (break_happened := true;()))) in - msg (stream ++ - (match vtp_tree with - Some t -> print_tree t - | None -> mt()));; - -let output_results_nl stream = - let _ = Sys.signal Sys.sigint - (Sys.Signal_handle(fun i -> break_happened := true;())) - in - msgnl stream;; - - -let rearm_break () = - let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break)) - in ();; - -let check_break () = - if (!break_happened) then - begin - break_happened := false; - raise Sys.Break - end - else ();; - -let print_past_goal index = - let path = History.get_path_for_rank (current_proof_name()) index in - try traverse_to path; - let pf = proof_of_pftreestate (get_pftreestate ()) in - output_results (ctf_PathGoalMessage ()) - (Some (P_r (translate_goal pf.goal))) - with - | Invalid_argument s -> - ((try traverse_to [] with _ -> ()); - error "No focused proof (No proof-editing in progress)") - | e -> (try traverse_to [] with _ -> ()); raise e -;; - -let show_nth n = - try - output_results (ctf_GoalReqIdMessage !global_request_id - ++ pr_nth_open_subgoal n) - None - with - | Invalid_argument s -> - error "No focused proof (No proof-editing in progress)";; - -let show_subgoals () = - try - output_results (ctf_GoalReqIdMessage !global_request_id - ++ pr_open_subgoals ()) - None - with - | Invalid_argument s -> - error "No focused proof (No proof-editing in progress)";; - -(* The rest of the file contains commands that are changed from the plain - Coq distribution *) - -let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);; - -(* -let filter_by_module_from_varg_list l = - let dir_list, b = Vernacentries.interp_search_restriction l in - Search.filter_by_module_from_list (dir_list, b);; -*) - -let add_search (global_reference:global_reference) assumptions cstr = - try - let id_string = - string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty - global_reference) in - let ast = - try - CT_premise (CT_ident id_string, translate_constr false assumptions cstr) - with Not_found -> - CT_premise (CT_ident id_string, - CT_coerce_ID_to_FORMULA( - CT_ident ("Error printing" ^ id_string))) in - ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST - with e -> msgnl (str "add_search raised an exception"); raise e;; - -(* -let make_error_stream node_string = - str "The syntax of " ++ str node_string ++ - str " is inconsistent with the vernac interpreter entry";; -*) - -let ctf_EmptyGoalMessage id = - fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; - - -let print_check env judg = - ((ctf_SearchResults !global_request_id) ++ - print_judgment env judg, - None);; - -let ct_print_eval red_fun env evmap ast judg = - (if refining() then traverse_to []); - let {uj_val=value; uj_type=typ} = judg in - let nvalue = (red_fun env evmap) value - (* // Attention , ici il faut peut être utiliser des environnemenst locaux *) - and ntyp = nf_betaiota typ in - print_tree - (P_pl - (CT_premises_list - [CT_eval_result - (xlate_formula ast, - translate_constr false env nvalue, - translate_constr false env ntyp)]));; - -let pbp_tac_pcoq = - pbp_tac (function (x:raw_tactic_expr) -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; - -let blast_tac_pcoq = - blast_tac (function (x:raw_tactic_expr) -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; - -(* <\cpa> -let dad_tac_pcoq = - dad_tac(function x -> - output_results - (ctf_header "pbp_results" !global_request_id) - (Some (P_t(xlate_tactic x))));; -</cpa> *) - -let search_output_results () = - (* LEM: See comments for pcoq_search *) - output_results - (ctf_SearchResults !global_request_id) - (Some (P_pl (CT_premises_list - (List.rev !ctv_SEARCH_LIST))));; - - -let debug_tac2_pcoq tac = - (fun g -> - let the_goal = ref (None : goal sigma option) in - let the_ast = ref tac in - let the_path = ref ([] : int list) in - try - let _result = report_error tac the_goal the_ast the_path [] g in - (errorlabstrm "DEBUG TACTIC" - (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++ - fnl () ++ str "the tactic is" ++ fnl () ++ - Pptactic.pr_glob_tactic (Global.env()) tac) (* -Caution, this is in the middle of what looks like dead code. ; - result *)) - with - e -> - match !the_goal with - None -> raise e - | Some g -> - (output_results - (ctf_Location !global_request_id) - (Some (P_s_int - (CT_signed_int_list - (List.map - (fun n -> CT_coerce_INT_to_SIGNED_INT - (CT_int n)) - (clean_path tac - (List.rev !the_path))))))); - (output_results - (ctf_OtherGoal !global_request_id) - (Some (P_r (translate_goal (sig_it g))))); - raise e);; - -let rec selectinspect n env = - match env with - [] -> [] - | a::tl -> - if n = 0 then - [] - else - match a with - (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl) - | _ -> (selectinspect n tl);; - -open Term;; - -let inspect n = - let env = Global.env() in - let add_search2 x y = add_search x env y in - let l = selectinspect n (Lib.contents_after None) in - ctv_SEARCH_LIST := []; - List.iter - (fun a -> - try - (match a with - oname, Lib.Leaf lobj -> - (match oname, object_tag lobj with - (sp,_), "VARIABLE" -> - let (_, _, v) = Global.lookup_named (basename sp) in - add_search2 (Nametab.locate (qualid_of_sp sp)) v - | (sp,kn), "CONSTANT" -> - let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in - add_search2 (Nametab.locate (qualid_of_sp sp)) typ - | (sp,kn), "MUTUALINDUCTIVE" -> - add_search2 (Nametab.locate (qualid_of_sp sp)) - (Pretyping.Default.understand Evd.empty (Global.env()) - (RRef(dummy_loc, IndRef(kn,0)))) - | _ -> failwith ("unexpected value 1 for "^ - (string_of_id (basename (fst oname))))) - | _ -> failwith "unexpected value") - with e -> ()) - l; - output_results - (ctf_SearchResults !global_request_id) - (Some - (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; - -let ct_int_to_TARG n = - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; - -let pair_list_to_ct l = - CT_user_tac(CT_ident "pair_int_list", - CT_targ_list - (List.map (fun (a,b) -> - CT_coerce_TACTIC_COM_to_TARG - (CT_user_tac - (CT_ident "pair_int", - CT_targ_list - [ct_int_to_TARG a; ct_int_to_TARG b]))) - l));; - -(* Annule toutes les commandes qui s'appliquent sur les sous-buts du - but auquel a été appliquée la n-ième tactique *) -let logical_kill n = - let path = History.get_path_for_rank (current_proof_name()) n in - begin - traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - (let kept_cmds, undone_cmds, remaining_goals, current_goal = - History.logical_undo (current_proof_name()) n in - output_results (ctf_undoResults !global_request_id) - (Some - (P_t - (CT_user_tac - (CT_ident "log_undo_result", - CT_targ_list - [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds); - CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds); - ct_int_to_TARG remaining_goals; - ct_int_to_TARG current_goal]))))); - traverse_to [] - end;; - -let simulate_solve n tac = - let path = History.get_nth_open_path (current_proof_name()) n in - solve_nth n (Tacinterp.hide_interp tac (get_end_tac())); - traverse_to path; - Pfedit.mutate weak_undo_pftreestate; - traverse_to [] - -let kill_node_verbose n = - let ngoals = kill_proof_node n in - output_results_nl (ctf_KilledMessage !global_request_id ngoals) - -let set_text_mode s = text_proof_flag := s - -let pcoq_reset_initial() = - output_results(ctf_AbortedAllMessage()) None; - Vernacentries.abort_refine Lib.reset_initial (); - output_results(ctf_ResetInitialMessage()) None;; - -let pcoq_reset x = - if refining() then - output_results (ctf_AbortedAllMessage ()) None; - Vernacentries.abort_refine Lib.reset_name (dummy_loc,x); - output_results - (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; - - -VERNAC ARGUMENT EXTEND text_mode -| [ "fr" ] -> [ "fr" ] -| [ "en" ] -> [ "en" ] -| [ "Off" ] -> [ "off" ] -END - -VERNAC COMMAND EXTEND TextMode -| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ] -END - -VERNAC COMMAND EXTEND OutputGoal - [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ] -END - -VERNAC COMMAND EXTEND OutputGoal - [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ] -END - -VERNAC COMMAND EXTEND KillProofAfter -| [ "Kill" "Proof" "after" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] -END - -VERNAC COMMAND EXTEND KillProofAt -| [ "Kill" "Proof" "at" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ] -END - -VERNAC COMMAND EXTEND KillSubProof - [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ] -END - -VERNAC COMMAND EXTEND PcoqReset - [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ] -END - -VERNAC COMMAND EXTEND PcoqResetInitial - [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ] -END - -let start_proof_hook () = - if !pcoq_history then History.start_proof (current_proof_name()); - current_goal_index := 1 - -let solve_hook n = - current_goal_index := n; - if !pcoq_history then - let name = current_proof_name () in - let old_n_count = History.border_length name in - let pf = proof_of_pftreestate (get_pftreestate ()) in - let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in - History.push_command name n n_goals - -let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) - -let interp_search_about_item = function - | SearchSubPattern pat -> - let _,pat = Constrintern.intern_constr_pattern Evd.empty (Global.env()) pat in - GlobSearchSubPattern pat - | SearchString (s,_) -> - warning "Notation case not taken into account"; - GlobSearchString s - -let pcoq_search s l = - (* LEM: I don't understand why this is done in this way (redoing the - * match on s here) instead of making the code in - * parsing/search.ml call the right function instead of - * "plain_display". Investigates this later. - * TODO - *) - ctv_SEARCH_LIST:=[]; - begin match s with - | SearchAbout sl -> - raw_search_about (filter_by_module_from_list l) add_search - (List.map (on_snd interp_search_about_item) sl) - | SearchPattern c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in - raw_pattern_search (filter_by_module_from_list l) add_search pat - | SearchRewrite c -> - let _,pat = intern_constr_pattern Evd.empty (Global.env()) c in - raw_search_rewrite (filter_by_module_from_list l) add_search pat; - | SearchHead locqid -> - filtered_search - (filter_by_module_from_list l) add_search (Nametab.global locqid) - end; - search_output_results() - -(* Check sequentially whether the pattern is one of the premises *) -let rec hyp_pattern_filter pat name a c = - let _c1 = strip_outer_cast c in - match kind_of_term c with - | Prod(_, hyp, c2) -> - (try -(* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in - let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) - if Matching.is_matching pat hyp then - (msgnl (str "ok"); true) - else - false - with UserError _ -> false) or - hyp_pattern_filter pat name a c2 - | _ -> false;; - -let hyp_search_pattern c l = - let _, pat = intern_constr_pattern Evd.empty (Global.env()) c in - ctv_SEARCH_LIST := []; - gen_filtered_search - (fun s a c -> (filter_by_module_from_list l s a c && - (if hyp_pattern_filter pat s a c then - (msgnl (str "ok2"); true) else false))) - (fun s a c -> (msgnl (str "ok3"); add_search s a c)); - output_results - (ctf_SearchResults !global_request_id) - (Some - (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; -let pcoq_print_name ref = - output_results - (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref ) - None - -let pcoq_print_check env j = - let a,b = print_check env j in output_results a b - -let pcoq_print_eval redfun env evmap c j = - output_results - (ctf_SearchResults !global_request_id - ++ Prettyp.print_eval redfun env evmap c j) - None;; - -open Vernacentries - -let pcoq_show_goal = function - | Some n -> show_nth n - | None -> show_subgoals () -;; - -let pcoq_hook = { - start_proof = start_proof_hook; - solve = solve_hook; - abort = abort_hook; - search = pcoq_search; - print_name = pcoq_print_name; - print_check = pcoq_print_check; - print_eval = pcoq_print_eval; - show_goal = pcoq_show_goal -} - -let pcoq_term_pr = { - pr_constr_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_constr_expr c)); - (* In future translate_constr false (Global.env()) - * Except with right bool/env which I'll get :) - *) - pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")"); - pr_constr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_constr_pattern_expr c)); - pr_lconstr_pattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lconstr_pattern_expr c)) -} - -let start_pcoq_trees () = - set_term_pr pcoq_term_pr - -(* BEGIN functions for object_pr *) - -(* These functions in general mirror what name_to_ast does in a subcase, - and then print the corresponding object as a PCoq tree. *) - -let object_to_ast_template object_to_ast_list sp = - let l = object_to_ast_list sp in - VernacList (List.map (fun x -> (dummy_loc, x)) l) - -let pcoq_print_object_template object_to_ast_list sp = - let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in - print_tree (P_cl results) - -(* This function mirror what print_check does *) - -let pcoq_print_typed_value_in_env env (value, typ) = - let value_ct_ast = - (try translate_constr false (Global.env()) value - with UserError(f,str) -> - raise(UserError(f,Printer.pr_lconstr value ++ - fnl () ++ str ))) in - let type_ct_ast = - (try translate_constr false (Global.env()) typ - with UserError(f,str) -> - raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in - print_tree - (P_pl - (CT_premises_list - [CT_coerce_TYPED_FORMULA_to_PREMISE - (CT_typed_formula(value_ct_ast,type_ct_ast) - )])) -;; - -(* This function mirrors what show_nth does *) - -let pcoq_pr_subgoal n gl = - try - print_tree - (if (!text_proof_flag<>"off") then - (* This is a horrendeous hack; it ignores the "gl" argument - and just takes the currently focused proof. This will bite - us back one day. - TODO: Fix this. - *) - ( - if not !pcoq_history then error "Text mode requires Pcoq history tracking."; - if n=0 - then (P_text (show_proof !text_proof_flag [])) - else - let path = History.get_nth_open_path (current_proof_name()) n in - (P_text (show_proof !text_proof_flag path))) - else - (let goal = List.nth gl (n - 1) in - (P_r (translate_goal goal)))) - with - | Invalid_argument _ - | Failure "nth" - | Not_found -> error "No such goal";; - -let pcoq_pr_subgoals close_cmd evar gl = - (*LEM: TODO: we should check for evar emptiness or not, and do something *) - try - print_tree - (if (!text_proof_flag<>"off") then - raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented")) - else - (P_rl (translate_goals gl))) - with - | Invalid_argument _ - | Failure "nth" - | Not_found -> error "No such goal";; - - -(* END functions for object_pr *) - -let pcoq_object_pr = { - print_inductive = pcoq_print_object_template inductive_to_ast_list; - (* TODO: Check what that with_infos means, and adapt accordingly *) - print_constant_with_infos = pcoq_print_object_template constant_to_ast_list; - print_section_variable = pcoq_print_object_template variable_to_ast_list; - print_syntactic_def = pcoq_print_object_template (fun x -> errorlabstrm "print" - (str "printing of syntax definitions not implemented in PCoq syntax")); - (* TODO: These are placeholders only; write them *) - print_module = (fun x y -> str "pcoq_print_module not implemented"); - print_modtype = (fun x -> str "pcoq_print_modtype not implemented"); - print_named_decl = (fun x -> str "pcoq_print_named_decl not implemented"); - (* TODO: Find out what the first argument x (a bool) is about and react accordingly *) - print_leaf_entry = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list); - print_library_entry = (fun x y -> Some (str "pcoq_print_library_entry not implemented")); - print_context = (fun x y z -> str "pcoq_print_context not implemented"); - print_typed_value_in_env = pcoq_print_typed_value_in_env; - Prettyp.print_eval = ct_print_eval; -};; - -let pcoq_printer_pr = { - pr_subgoals = pcoq_pr_subgoals; - pr_subgoal = pcoq_pr_subgoal; - pr_goal = (fun x -> str "pcoq_pr_goal not implemented"); -};; - - -let start_pcoq_objects () = - set_object_pr pcoq_object_pr; - set_printer_pr pcoq_printer_pr - -let start_default_objects () = - set_object_pr default_object_pr; - set_printer_pr default_printer_pr - -let full_name_of_ref r = - (match r with - | VarRef _ -> str "VAR" - | ConstRef _ -> str "CST" - | IndRef _ -> str "IND" - | ConstructRef _ -> str "CSR") - ++ str " " ++ (pr_sp (Nametab.sp_of_global r)) - (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *) - -let string_of_ref = - (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*) - Depends.o Libnames.string_of_path Nametab.sp_of_global - -let print_depends compute_depends ptree = - output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl()) - (str "This object depends on:" ++ fnl()) - (compute_depends ptree)) - None - -let output_depends compute_depends ptree = - (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *) - output_results (ctf_header "depends" !global_request_id ++ - print_tree (P_ids (CT_id_list (List.map - (fun x -> CT_ident (string_of_ref x)) - (compute_depends ptree))))) - None - -let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' = - Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[])); - Command.set_declare_assumption_hook (print_depends (fun (c:types) -> Depends.depends_of_constr c [])); - Command.set_start_hook (print_depends (fun c -> Depends.depends_of_constr c [])); - Command.set_save_hook (print_depends'' (Depends.depends_of_pftreestate Depends.depends_of_pftree)); - Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt [])) - -let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends - -let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends - -TACTIC EXTEND pbp -| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> - [ if_pcoq pbp_tac_pcoq idopt nl ] -END - -TACTIC EXTEND ct_debugtac -| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] -END - -TACTIC EXTEND ct_debugtac2 -| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] -END - - -let start_pcoq_mode debug = - begin - pcoq_started := Some debug; -(* <\cpa> - start_dad(); -</cpa> *) -(* The following ones are added to enable rich comments in pcoq *) -(* TODO ... - add_tactic "Image" (fun _ -> tclIDTAC); -*) -(* "Comments" moved to Vernacentries, other obsolete ? - List.iter (fun (a,b) -> vinterp_add a b) command_creations; -*) -(* Now hooks in Vernacentries - List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes; - if not debug then - List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes; -*) - set_pcoq_hook pcoq_hook; - start_pcoq_objects(); - Flags.print_emacs := false; Pp.make_pp_nonemacs(); - end;; - - -let start_pcoq () = - start_pcoq_mode false; - set_acknowledge_command ctf_acknowledge_command; - set_start_marker "CENTAUR_RESERVED_TOKEN_start_command"; - set_end_marker "CENTAUR_RESERVED_TOKEN_end_command"; - raise Vernacexpr.ProtectedLoop;; - -let start_pcoq_debug () = - start_pcoq_mode true; - set_acknowledge_command ctf_acknowledge_command; - set_start_marker "--->"; - set_end_marker "<---"; - raise Vernacexpr.ProtectedLoop;; - -VERNAC COMMAND EXTEND HypSearchPattern - [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ] -END - -VERNAC COMMAND EXTEND StartPcoq - [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ] -END - -VERNAC COMMAND EXTEND Pcoq_inspect - [ "Pcoq_inspect" ] -> [ inspect 15 ] -END - -VERNAC COMMAND EXTEND StartPcoqDebug -| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ] -END - -VERNAC COMMAND EXTEND StartPcoqTerms -| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ] -END - -VERNAC COMMAND EXTEND StartPcoqObjects -| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ] -END - -VERNAC COMMAND EXTEND StartDefaultObjects -| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ] -END - -VERNAC COMMAND EXTEND StartDependencyDumps -| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ] -END - -VERNAC COMMAND EXTEND StopPcoqHistory -| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ] -END diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml deleted file mode 100644 index c2ab2dc8..00000000 --- a/contrib/interface/dad.ml +++ /dev/null @@ -1,382 +0,0 @@ -(* This file contains an ml version of drag-and-drop. *) - -(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *) - -open Names;; -open Term;; -open Rawterm;; -open Util;; -open Environ;; -open Tactics;; -open Tacticals;; -open Pattern;; -open Matching;; -open Reduction;; -open Constrextern;; -open Constrintern;; -open Vernacinterp;; -open Libnames;; -open Nametab - -open Proof_type;; -open Proof_trees;; -open Tacmach;; -open Typing;; -open Pp;; - -open Paths;; - -open Topconstr;; -open Genarg;; -open Tacexpr;; -open Rawterm;; - -(* In a first approximation, drag-and-drop rules are like in CtCoq - 1/ a pattern, - 2,3/ Two paths: start and end positions, - 4/ the degree: the number of steps the algorithm should go up from the - longest common prefix, - 5/ the tail path: the suffix of the longest common prefix of length the - degree, - 6/ the command pattern, where meta variables are represented by objects - of the form Node(_,"META"; [Num(_,i)]) -*) - - -type dad_rule = - constr_expr * int list * int list * int * int list - * raw_atomic_tactic_expr;; - -(* This value will be used systematically when constructing objects *) - -let zz = Util.dummy_loc;; - -(* This function receives a length n, a path p, and a term and returns a - couple whose first component is the subterm designated by the prefix - of p of length n, and the second component is the rest of the path *) - -let rec get_subterm (depth:int) (path: int list) (constr:constr) = - match depth, path, kind_of_term constr with - 0, l, c -> (constr,l) - | n, 2::a::tl, App(func,arr) -> - get_subterm (n - 2) tl arr.(a-1) - | _,l,_ -> failwith (int_list_to_string - "wrong path or wrong form of term" - l);; - -(* This function maps a substitution on an abstract syntax tree. The - first argument, an object of type env, is necessary to - transform constr terms into abstract syntax trees. The second argument is - the substitution, a list of pairs linking an integer and a constr term. *) - -let rec map_subst (env :env) (subst:patvar_map) = function - | CPatVar (_,(_,i)) -> - let constr = List.assoc i subst in - extern_constr false env constr - | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;; - -let map_subst_tactic env subst = function - | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> - let c,bl = out_gen rawwit_constr_with_bindings cbl in - assert (bl = NoBindings); - let c = (map_subst env subst c,NoBindings) in - TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c]) - | _ -> failwith "map_subst_tactic: unsupported tactic" - -(* This function is really the one that is important. *) -let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = - match l with - [] -> failwith "nothing happens" - | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl -> - let length = List.length p in - try - if deg > length then - failwith "internal" - else - let term_to_match, p_r = - try - get_subterm (length - deg) p constr - with - Failure s -> failwith "internal" in - let _, constr_pat = - intern_constr_pattern Evd.empty (Global.env()) - ((*ct_to_ast*) pat) in - let subst = matches constr_pat term_to_match in - if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then - TacAtom (zz, map_subst_tactic env subst cmd) - else - failwith "internal" - with - Failure "internal" -> find_cmd tl env constr p p1 p2 - | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;; - - -let dad_rule_list = ref ([]: (string * dad_rule) list);; - -(* -(* \\ This function is also used in pbp. *) -let rec tactic_args_to_ints = function - [] -> [] - | (Integer n)::l -> n::(tactic_args_to_ints l) - | _ -> failwith "expecting only numbers";; - -(* We assume that the two lists of integers for the tactic are simply - given in one list, separated by a dummy tactic. *) -let rec part_tac_args l = function - [] -> l,[] - | (Tacexp a)::tl -> l, (tactic_args_to_ints tl) - | (Integer n)::tl -> part_tac_args (n::l) tl - | _ -> failwith "expecting only numbers and the word \"to\"";; - - -(* The dad_tac tactic takes a display_function as argument. This makes - it possible to use it in pcoq, but also in other contexts, just by - changing the output routine. *) -let dad_tac display_function = function - l -> let p1, p2 = part_tac_args [] l in - (function g -> - let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in - (display_function - (find_cmd (!dad_rule_list) (pf_env g) - (pf_concl g) p_a p1prime p2prime)); - tclIDTAC g);; -*) -let dad_tac display_function p1 p2 g = - let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in - (display_function - (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); - tclIDTAC g;; - -(* Now we enter dad rule list management. *) - -let add_dad_rule name patt p1 p2 depth pr command = - dad_rule_list := (name, - (patt, p1, p2, depth, pr, command))::!dad_rule_list;; - -let rec remove_if_exists name = function - [] -> false, [] - | ((a,b) as rule1)::tl -> if a = name then - let result1, l = (remove_if_exists name tl) in - true, l - else - let result1, l = remove_if_exists name tl in - result1, (rule1::l);; - -let remove_dad_rule name = - let result1, result2 = remove_if_exists name !dad_rule_list in - if result1 then - failwith("No such name among the drag and drop rules " ^ name) - else - dad_rule_list := result2;; - -let dad_rule_names () = - List.map (function (s,_) -> s) !dad_rule_list;; - -(* this function is inspired from matches_core in pattern.ml *) -let constrain ((n : patvar),(pat : constr_pattern)) sigma = - if List.mem_assoc n sigma then - if pat = (List.assoc n sigma) then sigma - else failwith "internal" - else - (n,pat)::sigma - -(* This function is inspired from matches_core in pattern.ml *) -let more_general_pat pat1 pat2 = - let rec match_rec sigma p1 p2 = - match p1, p2 with - | PMeta (Some n), m -> constrain (n,m) sigma - - | PMeta None, m -> sigma - - | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma - - | PVar v1, PVar v2 when v1 = v2 -> sigma - - | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma - - | PRel n1, PRel n2 when n1 = n2 -> sigma - - | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma - - | PSort (RType _), PSort (RType _) -> sigma - - | PApp (c1,arg1), PApp (c2,arg2) -> - (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 - with Invalid_argument _ -> failwith "internal") - | _ -> failwith "unexpected case in more_general_pat" in - try let _ = match_rec [] pat1 pat2 in true - with Failure "internal" -> false;; - -let more_general r1 r2 = - match r1,r2 with - (_,(patt1,p11,p12,_,_,_)), - (_,(patt2,p21,p22,_,_,_)) -> - (more_general_pat patt1 patt2) & - (is_prefix p11 p21) & (is_prefix p12 p22);; - -let not_less_general r1 r2 = - not (match r1,r2 with - (_,(patt1,p11,p12,_,_,_)), - (_,(patt2,p21,p22,_,_,_)) -> - (more_general_pat patt1 patt2) & - (is_prefix p21 p11) & (is_prefix p22 p12));; - -let rec add_in_list_sorting rule1 = function - [] -> [rule1] - | (b::tl) as this_list -> - if more_general rule1 b then - b::(add_in_list_sorting rule1 tl) - else if not_less_general rule1 b then - let tl2 = add_in_list_sorting_aux rule1 tl in - (match tl2 with - [] -> rule1::this_list - | _ -> b::tl2) - else - rule1::this_list -and add_in_list_sorting_aux rule1 = function - [] -> [] - | b::tl -> - if more_general rule1 b then - b::(add_in_list_sorting rule1 tl) - else - let tl2 = add_in_list_sorting_aux rule1 tl in - (match tl2 with - [] -> [] - | _ -> rule1::tl2);; - -let rec sort_list = function - [] -> [] - | a::l -> add_in_list_sorting a (sort_list l);; - -let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; -let mk_rewrite lr ast = - let b = in_gen rawwit_bool lr in - let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in - TacExtend (zz,"Rewrite",[b;cb]) - -open Vernacexpr - -let dad_status = ref false;; - -let start_dad () = dad_status := true;; - -let add_dad_rule_fn name pat p1 p2 tac = - let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in - add_dad_rule name pat p1 p2 (List.length pr) pr tac;; - -(* To be parsed by camlp4 - -(*i camlp4deps: "parsing/grammar.cma" i*) - -VERNAC COMMAND EXTEND AddDadRule - [ "Add" "Dad" "Rule" string(name) constr(pat) - "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] -> - [ add_dad_rule_fn name pat p1 p2 tac ] -END - -*) - -let mk_id s = mkIdentC (id_of_string s);; -let mkMetaC = mk_dad_meta;; - -add_dad_rule "distributivity-inv" -(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "distributivity1-r" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) -[2; 2; 2; 2] -[] -0 -[] -(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "distributivity1-l" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) -[2; 1; 2; 2] -[] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "associativity" -(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) -[2; 1] -[] -0 -[] -(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "minus-identity-lr" -(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) -[2; 1] -[2; 2] -1 -[2] -(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); - -add_dad_rule "minus-identity-rl" -(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); - -add_dad_rule "plus-sym-rl" -(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) -[2; 2] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "plus-sym-lr" -(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) -[2; 1] -[2; 2] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "absorb-0-r-rl" -(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) -[2; 2] -[1] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); - -add_dad_rule "absorb-0-r-lr" -(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) -[1] -[2; 2] -0 -[] -(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); - -add_dad_rule "plus-permute-lr" -(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) -[2; 1] -[2; 2; 2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); - -add_dad_rule "plus-permute-rl" -(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) -[2; 2; 2; 1] -[2; 1] -1 -[2] -(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; - -vinterp_add "StartDad" - (function - | [] -> - (function () -> start_dad()) - | _ -> errorlabstrm "StartDad" (mt()));; diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli deleted file mode 100644 index f556c192..00000000 --- a/contrib/interface/dad.mli +++ /dev/null @@ -1,10 +0,0 @@ -open Proof_type;; -open Tacmach;; -open Topconstr;; - -val dad_rule_names : unit -> string list;; -val start_dad : unit -> unit;; -val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma -> - goal list sigma * validation;; -val add_dad_rule : string -> constr_expr -> (int list) -> (int list) -> - int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;; diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 deleted file mode 100644 index aad3a765..00000000 --- a/contrib/interface/debug_tac.ml4 +++ /dev/null @@ -1,458 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Tacmach;; -open Tacticals;; -open Proof_trees;; -open Pp;; -open Pptactic;; -open Util;; -open Proof_type;; -open Tacexpr;; -open Genarg;; - -let pr_glob_tactic = Pptactic.pr_glob_tactic (Global.env()) - -(* Compacting and uncompacting proof commands *) - -type report_tree = - Report_node of bool *int * report_tree list - | Mismatch of int * int - | Tree_fail of report_tree - | Failed of int;; - -type report_card = - Ngoals of int - | Goals_mismatch of int - | Recursive_fail of report_tree - | Fail;; - -type card_holder = report_card ref;; -type report_holder = report_tree list ref;; - -(* This tactical receives an integer and a tactic and checks that the - tactic produces that number of goals. It never fails but signals failure - by updating the boolean reference given as third argument to false. - It is especially suited for use in checked_thens below. *) - -let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic = - fun card_holder count flag t g -> - try - let (gls, v) as result = t g in - let len = List.length (sig_it gls) in - card_holder := - (if len = count then - (flag := true; - Ngoals count) - else - (flag := false; - Goals_mismatch len)); - result - with - e -> card_holder := Fail; - flag := false; - tclIDTAC g;; - -let no_failure = function - [Report_node(true,_,_)] -> true - | _ -> false;; - -let check_subgoals_count2 - : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = - fun card_holder count flag t g -> - let new_report_holder = ref ([] : report_tree list) in - let (gls, v) as result = t new_report_holder g in - let succeeded = no_failure !new_report_holder in - let len = List.length (sig_it gls) in - card_holder := - (if (len = count) & succeeded then - (flag := true; - Ngoals count) - else - (flag := false; - Recursive_fail (List.hd !new_report_holder))); - result;; - -let traceable = function - | TacThen _ | TacThens _ -> true - | _ -> false;; - -let rec collect_status = function - Report_node(true,_,_)::tl -> collect_status tl - | [] -> true - | _ -> false;; - -(* This tactical receives a tactic and executes it, reporting information - about success in the report holder and a boolean reference. *) - -let count_subgoals : card_holder -> bool ref -> tactic -> tactic = - fun card_holder flag t g -> - try - let (gls, _) as result = t g in - card_holder := (Ngoals(List.length (sig_it gls))); - flag := true; - result - with - e -> card_holder := Fail; - flag := false; - tclIDTAC g;; - -let count_subgoals2 - : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = - fun card_holder flag t g -> - let new_report_holder = ref([] : report_tree list) in - let (gls, v) as result = t new_report_holder g in - let succeeded = no_failure !new_report_holder in - if succeeded then - (flag := true; - card_holder := Ngoals (List.length (sig_it gls))) - else - (flag := false; - card_holder := Recursive_fail(List.hd !new_report_holder)); - result;; - -let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function - TacThens (a,l) -> - (fun report_holder -> checked_thens report_holder a l) - | TacThen (a,[||],b,[||]) -> - (fun report_holder -> checked_then report_holder a b) - | t -> - (fun report_holder g -> - try - let (gls, _) as result = Tacinterp.eval_tactic t g in - report_holder := (Report_node(true, List.length (sig_it gls), [])) - ::!report_holder; - result - with e -> (report_holder := (Failed 1)::!report_holder; - tclIDTAC g)) - - -(* This tactical receives a tactic and a list of tactics as argument. - It applies the first tactic and then maps the list of tactics to - various produced sub-goals. This tactic will never fail, but reports - are added in the report_holder in the following way: - - In case of partial success, a new report_tree is added to the report_holder - - In case of failure of the first tactic, with no more indications - then Failed 0 is added to the report_holder, - - In case of partial failure of the first tactic then (Failed n) is added to - the report holder. - - In case of success of the first tactic, but count mismatch, then - Mismatch n is added to the report holder. *) - -and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = - (fun report_holder t1 l g -> - let flag = ref true in - let traceable_t1 = traceable t1 in - let card_holder = ref Fail in - let new_holder = ref ([]:report_tree list) in - let tac_t1 = - if traceable_t1 then - (check_subgoals_count2 card_holder (List.length l) - flag (local_interp t1)) - else - (check_subgoals_count card_holder (List.length l) - flag (Tacinterp.eval_tactic t1)) in - let (gls, _) as result = - tclTHEN_i tac_t1 - (fun i -> - if !flag then - (fun g -> - let tac_i = (List.nth l i) in - if traceable tac_i then - local_interp tac_i new_holder g - else - try - let (gls,_) as result = Tacinterp.eval_tactic tac_i g in - let len = List.length (sig_it gls) in - new_holder := - (Report_node(true, len, []))::!new_holder; - result - with - e -> (new_holder := (Failed 1)::!new_holder; - tclIDTAC g)) - else - tclIDTAC) g in - let new_goal_list = sig_it gls in - (if !flag then - report_holder := - (Report_node(collect_status !new_holder, - (List.length new_goal_list), - List.rev !new_holder))::!report_holder - else - report_holder := - (match !card_holder with - Goals_mismatch(n) -> Mismatch(n, List.length l) - | Recursive_fail tr -> Tree_fail tr - | Fail -> Failed 1 - | _ -> errorlabstrm "check_thens" - (str "this case should not happen in check_thens")):: - !report_holder); - result) - -(* This tactical receives two tactics as argument, it executes the - first tactic and applies the second one to all the produced goals, - reporting information about the success of all tactics in the report - holder. It never fails. *) - -and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic = - (fun report_holder t1 t2 g -> - let flag = ref true in - let card_holder = ref Fail in - let tac_t1 = - if traceable t1 then - (count_subgoals2 card_holder flag (local_interp t1)) - else - (count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in - let new_tree_holder = ref ([] : report_tree list) in - let (gls, _) as result = - tclTHEN tac_t1 - (fun (g:goal sigma) -> - if !flag then - if traceable t2 then - local_interp t2 new_tree_holder g - else - try - let (gls, _) as result = Tacinterp.eval_tactic t2 g in - new_tree_holder := - (Report_node(true, List.length (sig_it gls),[])):: - !new_tree_holder; - result - with - e -> - (new_tree_holder := ((Failed 1)::!new_tree_holder); - tclIDTAC g) - else - tclIDTAC g) g in - (if !flag then - report_holder := - (Report_node(collect_status !new_tree_holder, - List.length (sig_it gls), - List.rev !new_tree_holder))::!report_holder - else - report_holder := - (match !card_holder with - Recursive_fail tr -> Tree_fail tr - | Fail -> Failed 1 - | _ -> error "this case should not happen in check_then")::!report_holder); - result);; - -(* This tactic applies the given tactic only to those subgoals designated - by the list of integers given as extra arguments. - *) - -let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level -let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level -let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level - - -let on_then = function [t1;t2;l] -> - let t1 = out_gen wit_main_tactic t1 in - let t2 = out_gen wit_main_tactic t2 in - let l = out_gen (wit_list0 wit_int) l in - tclTHEN_i (Tacinterp.eval_tactic t1) - (fun i -> - if List.mem (i + 1) l then - (Tacinterp.eval_tactic t2) - else - tclIDTAC) - | _ -> anomaly "bad arguments for on_then";; - -let mkOnThen t1 t2 selected_indices = - let a = in_gen rawwit_main_tactic t1 in - let b = in_gen rawwit_main_tactic t2 in - let l = in_gen (wit_list0 rawwit_int) selected_indices in - TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));; - -(* Analyzing error reports *) - -let rec select_success n = function - [] -> [] - | Report_node(true,_,_)::tl -> n::select_success (n+1) tl - | _::tl -> select_success (n+1) tl;; - -let rec reconstruct_success_tac (tac:glob_tactic_expr) = - match tac with - TacThens (a,l) -> - (function - Report_node(true, n, l) -> tac - | Report_node(false, n, rl) -> - TacThens (a,List.map2 reconstruct_success_tac l rl) - | Failed n -> TacId [] - | Tree_fail r -> reconstruct_success_tac a r - | Mismatch (n,p) -> a) - | TacThen (a,[||],b,[||]) -> - (function - Report_node(true, n, l) -> tac - | Report_node(false, n, rl) -> - let selected_indices = select_success 1 rl in - TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", - [in_gen globwit_main_tactic a; - in_gen globwit_main_tactic b; - in_gen (wit_list0 globwit_int) selected_indices])) - | Failed n -> TacId [] - | Tree_fail r -> reconstruct_success_tac a r - | _ -> error "this error case should not happen in a THEN tactic") - | _ -> - (function - Report_node(true, n, l) -> tac - | Failed n -> TacId [] - | _ -> - errorlabstrm - "this error case should not happen on an unknown tactic" - (str "error in reconstruction with " ++ fnl () ++ - (pr_glob_tactic tac)));; - - -let rec path_to_first_error = function -| Report_node(true, _, l) -> - let rec find_first_error n = function - | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl - | it::tl -> n, it - | [] -> error "no error detected" in - let p, t = find_first_error 1 l in - p::(path_to_first_error t) -| _ -> [];; - -let debug_tac = function - [(Tacexp ast)] -> - (fun g -> - let report = ref ([] : report_tree list) in - let result = local_interp ast report g in - let clean_ast = (* expand_tactic *) ast in - let report_tree = - try List.hd !report with - Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in - let success_tac = - reconstruct_success_tac clean_ast report_tree in - let compact_success_tac = (* flatten_then *) success_tac in - msgnl (fnl () ++ - str "========= Successful tactic =============" ++ - fnl () ++ - pr_glob_tactic compact_success_tac ++ fnl () ++ - str "========= End of successful tactic ============"); - result) - | _ -> error "wrong arguments for debug_tac";; - -(* TODO ... used ? -add_tactic "DebugTac" debug_tac;; -*) - -Tacinterp.add_tactic "OnThen" on_then;; - -let rec clean_path tac l = - match tac, l with - | TacThen (a,[||],b,[||]), fst::tl -> - fst::(clean_path (if fst = 1 then a else b) tl) - | TacThens (a,l), 1::tl -> - 1::(clean_path a tl) - | TacThens (a,tacs), 2::fst::tl -> - 2::fst::(clean_path (List.nth tacs (fst - 1)) tl) - | _, [] -> [] - | _, _ -> failwith "this case should not happen in clean_path";; - -let rec report_error - : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> - int list -> tactic = - fun tac the_goal the_ast returned_path path -> - match tac with - TacThens (a,l) -> - let the_card_holder = ref Fail in - let the_flag = ref false in - let the_exn = ref (Failure "") in - tclTHENS - (fun g -> - let result = - check_subgoals_count - the_card_holder - (List.length l) - the_flag - (fun g2 -> - try - (report_error a the_goal the_ast returned_path (1::path) g2) - with - e -> (the_exn := e; raise e)) - g in - if !the_flag then - result - else - (match !the_card_holder with - Fail -> - the_ast := TacThens (!the_ast, l); - raise !the_exn - | Goals_mismatch p -> - the_ast := tac; - returned_path := path; - error ("Wrong number of tactics: expected " ^ - (string_of_int (List.length l)) ^ " received " ^ - (string_of_int p)) - | _ -> error "this should not happen")) - (let rec fold_num n = function - [] -> [] - | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path)):: - (fold_num (n + 1) tl) in - fold_num 1 l) - | TacThen (a,[||],b,[||]) -> - let the_count = ref 1 in - tclTHEN - (fun g -> - try - report_error a the_goal the_ast returned_path (1::path) g - with - e -> - (the_ast := TacThen (!the_ast,[||], b,[||]); - raise e)) - (fun g -> - try - let result = - report_error b the_goal the_ast returned_path (2::path) g in - the_count := !the_count + 1; - result - with - e -> - if !the_count > 1 then - msgnl - (str "in branch no " ++ int !the_count ++ - str " after tactic " ++ pr_glob_tactic a); - raise e) - | tac -> - (fun g -> - try - Tacinterp.eval_tactic tac g - with - e -> - (the_ast := tac; - the_goal := Some g; - returned_path := path; - raise e));; - -let strip_some = function - Some n -> n - | None -> failwith "No optional value";; - -let descr_first_error tac = - (fun g -> - let the_goal = ref (None : goal sigma option) in - let the_ast = ref tac in - let the_path = ref ([] : int list) in - try - let result = report_error tac the_goal the_ast the_path [] g in - msgnl (str "no Error here"); - result - with - e -> - (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ - fnl () ++ Cerrors.explain_exn e ++ fnl () ++ - fnl () ++ str "on goal" ++ fnl () ++ - Printer.pr_goal (sig_it (strip_some !the_goal)) ++ - fnl () ++ str "faulty tactic is" ++ fnl () ++ fnl () ++ - pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ()); - tclIDTAC g)) - -(* TODO ... used ?? -add_tactic "DebugTac2" descr_first_error;; -*) - -(* -TACTIC EXTEND DebugTac2 - [ ??? ] -> [ descr_first_error tac ] -END -*) diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli deleted file mode 100644 index da4bbaa0..00000000 --- a/contrib/interface/debug_tac.mli +++ /dev/null @@ -1,6 +0,0 @@ - -val report_error : Tacexpr.glob_tactic_expr -> - Proof_type.goal Evd.sigma option ref -> - Tacexpr.glob_tactic_expr ref -> int list ref -> int list -> Tacmach.tactic;; - -val clean_path : Tacexpr.glob_tactic_expr -> int list -> int list;; diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml deleted file mode 100644 index e0f43193..00000000 --- a/contrib/interface/depends.ml +++ /dev/null @@ -1,454 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant *) -(* <O___,, * *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1, *) -(* * or (at your option) any later version. *) -(************************************************************************) - -(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *) - -(* This is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) -(* Lesser General Public License for more details. *) - -(* You should have received a copy of the GNU Lesser General Public *) -(* License along with this library; if not, write to the Free Software *) -(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, *) -(* MA 02110-1301, USA *) - - -(* LEM TODO: a .mli file *) - -open Refiner -open Proof_type -open Rawterm -open Term -open Libnames -open Util -open Tacexpr -open Entries - -(* DBG utilities, to be removed *) -let print_bool b = print_string (string_of_bool b) -let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter() -let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O" -(* End utilities, to be removed *) - -let explore_tree pfs = - print_string "explore_tree called\n"; - print_string "pfs is a top: "; - (* We expect yes. *) - print_string (if (is_top_pftreestate pfs) then "yes" else "no"); - print_newline(); - let rec explain_tree (pt:proof_tree) = - match pt.ref with - | None -> "none" - | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" - | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">" - | Some (Decl_proof _, _) -> "Decl_proof" - | Some (Daimon, _) -> "Daimon" - and explain_compound cr = - match cr with - | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")" - | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")" - and explain_prim = function - | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c)) - | Intro identifier -> "Intro" - | Cut (bool, _, identifier, types) -> "Cut" - | FixRule (identifier, int, l, _) -> "FixRule" - | Cofix (identifier, l, _) -> "Cofix" - | Convert_concl (types, cast_kind) -> "Convert_concl" - | Convert_hyp named_declaration -> "Convert_hyp" - | Thin identifier_list -> "Thin" - | ThinBody identifier_list -> "ThinBody" - | Move (bool, identifier, identifier') -> "Move" - | Rename (identifier, identifier') -> "Rename" - | Change_evars -> "Change_evars" - | Order _ -> "Order" - in - let pt = proof_of_pftreestate pfs in - (* We expect 0 *) - print_string "Number of open subgoals: "; - print_int pt.open_subgoals; - print_newline(); - print_string "First rule is a "; - print_string (explain_tree pt); - print_newline() - - -let o f g x = f (g x) -let fst_of_3 (x, _, _) = x -let snd_of_3 (_, x, _) = x -let trd_of_3 (_, _, x) = x - -(* TODO: These for now return a Libnames.global_reference, but a - prooftree will also depend on things like tactic declarations, etc - so we may need a new type for that. *) -let rec depends_of_hole_kind hk acc = match hk with - | Evd.ImplicitArg (gr,_) -> gr::acc - | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc - | Evd.BinderType _ - | Evd.QuestionMark _ - | Evd.CasesType - | Evd.InternalHole - | Evd.GoalEvar - | Evd.ImpossibleCase -> acc - -let depends_of_'a_cast_type depends_of_'a act acc = match act with - | CastConv (ck, a) -> depends_of_'a a acc - | CastCoerce -> acc - -let depends_of_'a_bindings depends_of_'a ab acc = match ab with - | ImplicitBindings al -> list_union_map depends_of_'a al acc - | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc - | NoBindings -> acc - -let depends_of_'a_with_bindings depends_of_'a (a, ab) acc = - depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc) - -(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *) -(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *) - -let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with - | ElimOnConstr a -> depends_of_'a a acc - | ElimOnIdent _ -> - (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.) - * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-( - - * Plan: Load all section variables before anything in that - * section and call the user's proof script "brittle" and refuse - * to handle if it breaks because of that - *) - acc - | ElimOnAnonHyp _ -> acc - -let depends_of_'a_or_var depends_of_'a aov acc = match aov with - | ArgArg a -> depends_of_'a a acc - | ArgVar _ -> acc - -let depends_of_'a_with_occurences depends_of_'a (_,a) acc = - depends_of_'a a acc - -let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with - (* TODO: dirty assumption that the 'b doesn't make any dependency *) - | Red _ - | Hnf - | Cbv _ - | Lazy _ - | Unfold _ - | ExtraRedExpr _ - | CbvVm -> acc - | Simpl awoo -> - Option.fold_right - (depends_of_'a_with_occurences depends_of_'a) - awoo - acc - | Fold al -> list_union_map depends_of_'a al acc - | Pattern awol -> - list_union_map - (depends_of_'a_with_occurences depends_of_'a) - awol - acc - -let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with - (* TODO: dirty assumption that the 'b doesn't make any dependency *) - | NonDepInversion _ -> acc - | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc - | InversionUsing (a, _) -> depends_of_'a a acc - -let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc - -let depends_of_named_vals nvs acc = - (* TODO: I'm stopping here because I have noooo idea what to do with values... *) - acc - -let depends_of_inductive ind acc = (IndRef ind)::acc - -let rec depends_of_constr c acc = match kind_of_term c with - | Rel _ -> acc - | Var id -> (VarRef id)::acc - | Meta _ -> acc - | Evar ev -> depends_of_'a_pexistential depends_of_constr ev acc - | Sort _ -> acc - | Cast (c, _, t) -> depends_of_constr c (depends_of_constr t acc) - | Prod (_, t, t') -> depends_of_constr t (depends_of_constr t' acc) - | Lambda (_, t, c) -> depends_of_constr t (depends_of_constr c acc) - | LetIn (_, c, t, c') -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc)) - | App (c, ca) -> depends_of_constr c (array_union_map depends_of_constr ca acc) - | Const cnst -> (ConstRef cnst)::acc - | Ind ind -> (IndRef ind)::acc - | Construct cons -> (ConstructRef cons)::acc - | Case (_, c, c', ca) -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc)) - | Fix (_, (_, ta, ca)) - | CoFix (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc) -and depends_of_evar_map evm acc = - Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc -and depends_of_evar_info evi acc = - (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *) - depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc)) -and depends_of_evar_body evb acc = match evb with - | Evd.Evar_empty -> acc - | Evd.Evar_defined c -> depends_of_constr c acc -and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc -and depends_of_named_context_val ncv acc = - depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc) -and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc) - - - -let depends_of_open_constr (evm,c) acc = - depends_of_constr c (depends_of_evar_map evm acc) - -let rec depends_of_rawconstr rc acc = match rc with - | RRef (_,r) -> r::acc - | RVar (_, id) -> (VarRef id)::acc - | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc - | RPatVar _ -> acc - | RApp (_, rc, rcl) -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc) - | RLambda (_, _, _, rct, rcb) - | RProd (_, _, _, rct, rcb) - | RLetIn (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc) - | RCases (_, _, rco, tmt, cc) -> - (* LEM TODO: handle the cc *) - (Option.fold_right depends_of_rawconstr rco - (list_union_map - (fun (rc, pp) acc -> - Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp) - (depends_of_rawconstr rc acc)) - tmt - acc)) - | RLetTuple (_,_,(_,rco),rc0,rc1) -> - depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc)) - | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in - dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc)))) - | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in - dorca rca0 (dorca rca1 (array_union_map - (list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc))) - rdla - acc)) - | RSort _ -> acc - | RHole (_, hk) -> depends_of_hole_kind hk acc - | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc) - | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*) -and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l - -let depends_of_rawconstr_and_expr (rc, _) acc = - (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *) - depends_of_rawconstr rc acc - -let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac = - (* TODO: - * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies - *) - let rec depends_of_tacexpr texp acc = match texp with - | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc - | TacThen (tac0, taca0, tac1, taca1) -> - depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc))) - | TacThens (tac, tacl) -> - depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc) - | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc - | TacComplete tac -> depends_of_tacexpr tac acc - | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc - | TacTry tac -> depends_of_tacexpr tac acc - | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc) - | TacDo (_, tac) -> depends_of_tacexpr tac acc - | TacRepeat tac -> depends_of_tacexpr tac acc - | TacProgress tac -> depends_of_tacexpr tac acc - | TacAbstract (tac, _) -> depends_of_tacexpr tac acc - | TacId _ - | TacFail _ -> acc - | TacInfo tac -> depends_of_tacexpr tac acc - | TacLetIn (_, igtal, tac) -> - depends_of_tacexpr - tac - (list_union_map - (fun x y -> depends_of_tac_arg (snd x) y) - igtal - acc) - | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet" - | TacMatchGoal (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet" - | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc - | TacArg tacarg -> depends_of_tac_arg tacarg acc - and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with - (* Basic tactics *) - | TacIntroPattern _ - | TacIntrosUntil _ - | TacIntroMove _ - | TacAssumption -> acc - | TacExact c - | TacExactNoCheck c - | TacVmCastNoCheck c -> depends_of_'constr c acc - | TacApply (_, _, [cb], None) -> depends_of_'constr_with_bindings cb acc - | TacApply (_, _, _, _) -> failwith "TODO" - | TacElim (_, cwb, cwbo) -> - depends_of_'constr_with_bindings cwb - (Option.fold_right depends_of_'constr_with_bindings cwbo acc) - | TacElimType c -> depends_of_'constr c acc - | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc - | TacCaseType c -> depends_of_'constr c acc - | TacFix _ - | TacMutualFix _ - | TacCofix _ - | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet" - | TacCut c -> depends_of_'constr c acc - | TacAssert (taco, _, c) -> - Option.fold_right depends_of_'tac taco (depends_of_'constr c acc) - | TacGeneralize cl -> - list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl) - acc - | TacGeneralizeDep c -> depends_of_'constr c acc - | TacLetTac (_,c,_,_) -> depends_of_'constr c acc - - (* Derived basic tactics *) - | TacSimpleInductionDestruct _ - | TacDoubleInduction _ -> acc - | TacInductionDestruct (_, _, [cwbial, cwbo, _, _]) -> - list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings) - cwbial - (Option.fold_right depends_of_'constr_with_bindings cwbo acc) - | TacInductionDestruct (_, _, _) -> failwith "TODO" - | TacDecomposeAnd c - | TacDecomposeOr c -> depends_of_'constr c acc - | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc) - | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc - | TacLApply c -> depends_of_'constr c acc - - (* Automation tactics *) - | TacTrivial (cl, bs) -> - (* TODO: Maybe make use of bs: list of hint bases to be used. *) - list_union_map depends_of_'constr cl acc - | TacAuto (_, cs, bs) -> - (* TODO: Maybe make use of bs: list of hint bases to be used. - None -> all ("with *") - Some list -> a list, "core" added implicitly *) - list_union_map depends_of_'constr cs acc - | TacAutoTDB _ -> acc - | TacDestructHyp _ -> acc - | TacDestructConcl -> acc - | TacSuperAuto _ -> (* TODO: this reference thing is scary*) - acc - | TacDAuto _ -> acc - - (* Context management *) - | TacClear _ - | TacClearBody _ - | TacMove _ - | TacRename _ - | TacRevert _ -> acc - - (* Constructors *) - | TacLeft (_,cb) - | TacRight (_,cb) - | TacSplit (_, _, cb) - | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc - | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc - - (* Conversion *) - | TacReduce (reg,_) -> - depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc - | TacChange (cwoo, c, _) -> - depends_of_'constr - c - (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc) - - (* Equivalence relations *) - | TacReflexivity - | TacSymmetry _ -> acc - | TacTransitivity c -> depends_of_'constr c acc - - (* Equality and inversion *) - | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc - | TacInversion (is, _) -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc - - (* For ML extensions *) - | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented" - - (* For syntax extensions *) - | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented" - and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet" - and depends_of_tac_arg ta acc = match ta with - | TacDynamic (_,d) -> failwith "Don't know what to do with a Dyn in tac_arg" - | TacVoid -> acc - | MetaIdArg _ -> failwith "Don't know what to do with a MetaIdArg in tac_arg" - | ConstrMayEval me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval" - | IntroPattern _ -> acc - | Reference ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) - | Integer _ -> acc - | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *) - list_union_map depends_of_tac_arg l acc - | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc - | TacFreshId _ -> acc - | Tacexp tac -> - depends_of_'tac tac acc - in - depends_of_tacexpr - -let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc = - depends_of_gen_tactic_expr - depends_of_rawconstr_and_expr - (depends_of_'a_or_var depends_of_inductive) - depends_of_glob_tactic_expr - gte - acc - -let rec depends_of_tacexpr te acc = - depends_of_gen_tactic_expr - depends_of_open_constr - depends_of_inductive - depends_of_glob_tactic_expr - te - acc - -let depends_of_compound_rule cr acc = match cr with - | Tactic (texp, _) -> depends_of_tacexpr texp acc - | Proof_instr (b, instr) -> - (* TODO: What is the boolean b? Should check. *) - failwith "Dependency calculation of Proof_instr not implemented yet" -and depends_of_prim_rule pr acc = match pr with - | Refine c -> depends_of_constr c acc - | Intro id -> acc - | Cut (_, _, _, t) -> depends_of_constr t acc (* TODO: check what 3nd argument contains *) - | FixRule (_, _, l, _) -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *) - | Cofix (_, l, _) -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *) - | Convert_concl (t, _) -> depends_of_constr t acc - | Convert_hyp (_, None, t) -> depends_of_constr t acc - | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc) - | Thin _ -> acc - | ThinBody _ -> acc - | Move _ -> acc - | Rename _ -> acc - | Change_evars -> acc - | Order _ -> acc - -let rec depends_of_pftree pt acc = - match pt.ref with - | None -> acc - | Some (Prim pr , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l acc) - | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc)) - | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc - | Some (Daimon, l) -> list_union_map depends_of_pftree l acc - -let rec depends_of_pftree_head pt acc = - match pt.ref with - | None -> acc - | Some (Prim pr , l) -> depends_of_prim_rule pr acc - | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc) - | Some (Decl_proof _ , l) -> acc - | Some (Daimon, l) -> acc - -let depends_of_pftreestate depends_of_pftree pfs = -(* print_string "depends_of_pftreestate called\n"; *) -(* explore_tree pfs; *) - let pt = proof_of_pftreestate pfs in - assert (is_top_pftreestate pfs); - assert (pt.open_subgoals = 0); - depends_of_pftree pt [] - -let depends_of_definition_entry de ~acc = - Option.fold_right - depends_of_constr - de.const_entry_type - (depends_of_constr de.const_entry_body acc) diff --git a/contrib/interface/history.ml b/contrib/interface/history.ml deleted file mode 100644 index f73c2084..00000000 --- a/contrib/interface/history.ml +++ /dev/null @@ -1,373 +0,0 @@ -open Paths;; - -type tree = {mutable index : int; - parent : tree option; - path_to_root : int list; - mutable is_open : bool; - mutable sub_proofs : tree list};; - -type prf_info = { - mutable prf_length : int; - mutable ranks_and_goals : (int * int * tree) list; - mutable border : tree list; - prf_struct : tree};; - -let theorem_proofs = ((Hashtbl.create 17): - (string, prf_info) Hashtbl.t);; - - -let rec mk_trees_for_goals path tree rank k n = - if k = (n + 1) then - [] - else - { index = rank; - parent = tree; - path_to_root = k::path; - is_open = true; - sub_proofs = [] } ::(mk_trees_for_goals path tree rank (k+1) n);; - - -let push_command s rank ngoals = - let ({prf_length = this_length; - ranks_and_goals = these_ranks; - border = this_border} as proof_info) = - Hashtbl.find theorem_proofs s in - let rec push_command_aux n = function - [] -> failwith "the given rank was too large" - | a::l -> - if n = 1 then - let {path_to_root = p} = a in - let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in - new_trees,(new_trees@l),a - else - let new_trees, res, this_tree = push_command_aux (n-1) l in - new_trees,(a::res),this_tree in - let new_trees, new_border, this_tree = - push_command_aux rank this_border in - let new_length = this_length + 1 in - begin - proof_info.border <- new_border; - proof_info.prf_length <- new_length; - proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks; - this_tree.index <- new_length; - this_tree.is_open <- false; - this_tree.sub_proofs <- new_trees - end;; - -let get_tree_for_rank thm_name rank = - let {ranks_and_goals=l;prf_length=n} = - Hashtbl.find theorem_proofs thm_name in - let rec get_tree_aux = function - [] -> - failwith - "inconsistent values for thm_name and rank in get_tree_for_rank" - | (_,_,({index=i} as tree))::tl -> - if i = rank then - tree - else - get_tree_aux tl in - get_tree_aux l;; - -let get_path_for_rank thm_name rank = - let {path_to_root=l}=get_tree_for_rank thm_name rank in - l;; - -let rec list_descendants_aux l tree = - let {index = i; is_open = open_status; sub_proofs = tl} = tree in - let res = (List.fold_left list_descendants_aux l tl) in - if open_status then i::res else res;; - -let list_descendants thm_name rank = - list_descendants_aux [] (get_tree_for_rank thm_name rank);; - -let parent_from_rank thm_name rank = - let {parent=mommy} = get_tree_for_rank thm_name rank in - match mommy with - Some x -> Some x.index - | None -> None;; - -let first_child_command thm_name rank = - let {sub_proofs = l} = get_tree_for_rank thm_name rank in - let rec first_child_rec = function - [] -> None - | {index=i;is_open=b}::l -> - if b then - (first_child_rec l) - else - Some i in - first_child_rec l;; - -type index_or_rank = Is_index of int | Is_rank of int;; - -let first_child_command_or_goal thm_name rank = - let proof_info = Hashtbl.find theorem_proofs thm_name in - let {sub_proofs=l}=get_tree_for_rank thm_name rank in - match l with - [] -> None - | ({index=i;is_open=b} as t)::_ -> - if b then - let rec get_rank n = function - [] -> failwith "A goal is lost in first_child_command_or_goal" - | a::l -> - if a==t then - n - else - get_rank (n + 1) l in - Some(Is_rank(get_rank 1 proof_info.border)) - else - Some(Is_index i);; - -let next_sibling thm_name rank = - let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in - match mommy with - None -> None - | Some real_mommy -> - let {sub_proofs=l}=real_mommy in - let rec next_sibling_aux b = function - (opt_first, []) -> - if b then - opt_first - else - failwith "inconsistency detected in next_sibling" - | (opt_first, {is_open=true}::l) -> - next_sibling_aux b (opt_first, l) - | (Some(first),({index=i; is_open=false} as t')::l) -> - if b then - Some i - else - next_sibling_aux (t == t') (Some first,l) - | None,({index=i;is_open=false} as t')::l -> - next_sibling_aux (t == t') ((Some i), l) - in - Some (next_sibling_aux false (None, l));; - - -let prefix l1 l2 = - let l1rev = List.rev l1 in - let l2rev = List.rev l2 in - is_prefix l1rev l2rev;; - -let rec remove_all_prefixes p = function - [] -> [] - | a::l -> - if is_prefix p a then - (remove_all_prefixes p l) - else - a::(remove_all_prefixes p l);; - -let recompute_border tree = - let rec recompute_border_aux tree acc = - let {is_open=b;sub_proofs=l}=tree in - if b then - tree::acc - else - List.fold_right recompute_border_aux l acc in - recompute_border_aux tree [];; - - -let historical_undo thm_name rank = - let ({ranks_and_goals=l} as proof_info)= - Hashtbl.find theorem_proofs thm_name in - let rec undo_aux acc = function - [] -> failwith "bad rank provided for undoing in historical_undo" - | (r, n, ({index=i} as tree))::tl -> - let this_path_reversed = List.rev tree.path_to_root in - let res = remove_all_prefixes this_path_reversed acc in - if i = rank then - begin - proof_info.prf_length <- i-1; - proof_info.ranks_and_goals <- tl; - tree.is_open <- true; - tree.sub_proofs <- []; - proof_info.border <- recompute_border proof_info.prf_struct; - this_path_reversed::res - end - else - begin - tree.is_open <- true; - tree.sub_proofs <- []; - undo_aux (this_path_reversed::res) tl - end - in - List.map List.rev (undo_aux [] l);; - -(* The following function takes a list of trees and compute the - number of elements whose path is lexically smaller or a suffixe of - the path given as a first argument. This works under the precondition that - the list is lexicographically order. *) - -let rec logical_undo_on_border the_tree rev_path = function - [] -> (0,[the_tree]) - | ({path_to_root=p}as tree)::tl -> - let p_rev = List.rev p in - if is_prefix rev_path p_rev then - let (k,res) = (logical_undo_on_border the_tree rev_path tl) in - (k+1,res) - else if lex_smaller p_rev rev_path then - let (k,res) = (logical_undo_on_border the_tree rev_path tl) in - (k,tree::res) - else - (0, the_tree::tree::tl);; - - -let logical_undo thm_name rank = - let ({ranks_and_goals=l; border=last_border} as proof_info)= - Hashtbl.find theorem_proofs thm_name in - let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in - let rev_ref_path = List.rev ref_path in - let rec logical_aux lex_smaller_offset family_width = function - [] -> failwith "this case should never happen in logical_undo" - | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree)):: - tl -> - let this_path_rev = List.rev this_path in - let new_rank, new_offset, new_width, kept = - if is_prefix rev_ref_path this_path_rev then - (r + lex_smaller_offset), lex_smaller_offset, - (family_width + 1 - n), false - else if lex_smaller this_path_rev rev_ref_path then - r, (lex_smaller_offset - 1 + n), family_width, true - else - (r + 1 - family_width+ lex_smaller_offset), - lex_smaller_offset, family_width, true in - if i=rank then - [i,new_rank],[], tl, rank - else - let ranks_undone, ranks_kept, ranks_and_goals, current_rank = - (logical_aux new_offset new_width tl) in - begin - if kept then - begin - tree.index <- current_rank; - ranks_undone, ((i,new_rank)::ranks_kept), - ((new_rank, n, tree)::ranks_and_goals), - (current_rank + 1) - end - else - ((i,new_rank)::ranks_undone), ranks_kept, - ranks_and_goals, current_rank - end in - let number_suffix, new_border = - logical_undo_on_border ref_tree rev_ref_path last_border in - let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, - new_length_plus_one = logical_aux 0 number_suffix l in - let the_goal_index = - let rec compute_goal_index n = function - [] -> failwith "this case should never happen in logical undo (2)" - | {path_to_root=path}::tl -> - if List.rev path = (rev_ref_path) then - n - else - compute_goal_index (n+1) tl in - compute_goal_index 1 new_border in - begin - ref_tree.is_open <- true; - ref_tree.sub_proofs <- []; - proof_info.border <- new_border; - proof_info.ranks_and_goals <- new_ranks_and_goals; - proof_info.prf_length <- new_length_plus_one - 1; - changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, - the_goal_index - end;; - -let start_proof thm_name = - let the_tree = - {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in - Hashtbl.add theorem_proofs thm_name - {prf_length=0; - ranks_and_goals=[]; - border=[the_tree]; - prf_struct=the_tree};; - -let dump_sequence chan s = - match (Hashtbl.find theorem_proofs s) with - {ranks_and_goals=l}-> - let rec dump_rec = function - [] -> () - | (r,n,_)::tl -> - dump_rec tl; - output_string chan (string_of_int r); - output_string chan ","; - output_string chan (string_of_int n); - output_string chan "\n" in - begin - dump_rec l; - output_string chan "end\n" - end;; - - -let proof_info_as_string s = - let res = ref "" in - match (Hashtbl.find theorem_proofs s) with - {prf_struct=tree} -> - let open_goal_counter = ref 0 in - let rec dump_rec = function - {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> - begin - (match the_parent with - None -> - if op then - res := !res ^ "\"open goal\"\n" - | Some {index=j} -> - begin - res := !res ^ (string_of_int j); - res := !res ^ " -> "; - if op then - begin - res := !res ^ "\"open goal "; - open_goal_counter := !open_goal_counter + 1; - res := !res ^ (string_of_int !open_goal_counter); - res := !res ^ "\"\n"; - end - else - begin - res := !res ^ (string_of_int i); - res := !res ^ "\n" - end - end); - List.iter dump_rec trees - end in - dump_rec tree; - !res;; - - -let dump_proof_info chan s = - match (Hashtbl.find theorem_proofs s) with - {prf_struct=tree} -> - let open_goal_counter = ref 0 in - let rec dump_rec = function - {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> - begin - (match the_parent with - None -> - if op then - output_string chan "\"open goal\"\n" - | Some {index=j} -> - begin - output_string chan (string_of_int j); - output_string chan " -> "; - if op then - begin - output_string chan "\"open goal "; - open_goal_counter := !open_goal_counter + 1; - output_string chan (string_of_int !open_goal_counter); - output_string chan "\"\n"; - end - else - begin - output_string chan (string_of_int i); - output_string chan "\n" - end - end); - List.iter dump_rec trees - end in - dump_rec tree;; - -let get_nth_open_path s n = - match Hashtbl.find theorem_proofs s with - {border=l} -> - let {path_to_root=p}=List.nth l (n - 1) in - p;; - -let border_length s = - match Hashtbl.find theorem_proofs s with - {border=l} -> List.length l;; diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli deleted file mode 100644 index 053883f0..00000000 --- a/contrib/interface/history.mli +++ /dev/null @@ -1,12 +0,0 @@ -type prf_info;; - -val start_proof : string -> unit;; -val historical_undo : string -> int -> int list list -val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int -val dump_sequence : out_channel -> string -> unit -val proof_info_as_string : string -> string -val dump_proof_info : out_channel -> string -> unit -val push_command : string -> int -> int -> unit -val get_path_for_rank : string -> int -> int list -val get_nth_open_path : string -> int -> int list -val border_length : string -> int diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4 deleted file mode 100755 index 0b13a092..00000000 --- a/contrib/interface/line_parser.ml4 +++ /dev/null @@ -1,241 +0,0 @@ -(* line-oriented Syntactic analyser for a Coq parser *) -(* This parser expects a very small number of commands, each given on a complete -line. Some of these commands are then followed by a text fragment terminated -by a precise keyword, which is also expected to appear alone on a line. *) - -(* The main parsing loop procedure is "parser_loop", given at the end of this -file. It read lines one by one and checks whether they can be parsed using -a very simple parser. This very simple parser uses a lexer, which is also given -in this file. - -The lexical analyser: - There are only 5 sorts of tokens *) -type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | - Tlbracket | Trbracket;; - -(* When recognizing identifiers or strings, the lexical analyser accumulates - the characters in a buffer, using the command add_in_buff. To recuperate - the characters, one can use get_buff (this code was inspired by the - code in src/meta/lexer.ml of Coq revision 6.1) *) -let add_in_buff,get_buff = - let buff = ref (String.create 80) in - (fun i x -> - let len = String.length !buff in - if i >= len then (buff := !buff ^ (String.create len);()); - String.set !buff i x; - succ i), - (fun len -> String.sub !buff 0 len);; - -(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*. When arriving here the first - character has already been recognized. *) -let rec ident len = parser - [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] -> - ident (add_in_buff len c) s -| [< >] -> let str = get_buff len in Tid(str);; - -(* While recognizing integers, one constructs directly the integer value. - The ascii code of '0' is important for this. *) -let code0 = Char.code '0';; - -let get_digit c = Char.code c - code0;; - -(* Integers are [0-9]* - The variable intval is the integer value of the text that has already - been recognized. As for identifiers, the first character has already been - recognized. *) - -let rec parse_int intval = parser - [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i -| [< >] -> Tint intval;; - -(* The string lexer is borrowed from the string parser of Coq V6.1 - This may be a problem if convention have changed in Coq, - However this parser is only used to recognize file names which should - not contain too many special characters *) - -let rec spec_char = parser - [< ''n' >] -> '\n' -| [< ''t' >] -> '\t' -| [< ''b' >] -> '\008' -| [< ''r' >] -> '\013' -| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> - Char.chr v -| [< 'x >] -> x - -and spec1 v = parser - [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s -| [< >] -> v -;; - -(* This is the actual string lexical analyser. Strings are - QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used - to represents double quotation characters, that cannot be used - freely, even inside comments. *) - -let rec string len = parser - [< ''"' >] -> len -| [<''\\' ; - len = (parser [< ''\n' >] -> len - | [< c=spec_char >] -> add_in_buff len c); - s >] -> string len s -| [< 'x; s >] -> string (add_in_buff len x) s;; - -(* The lexical analyser repeats the recognized given by next_token: - spaces and tabulations are ignored, identifiers, integers, - strings, opening and closing square brackets. Lexical errors are - ignored ! *) -let rec next_token = parser _count - [< '' ' | '\t'; tok = next_token >] -> tok -| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i -| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i -| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len) -| [< ''[' >] -> Tlbracket -| [< '']' >] -> Trbracket -| [< '_ ; x = next_token >] -> x;; - -(* A very simple lexical analyser to recognize a integer value behind - blank characters *) - -let rec next_int = parser _count - [< '' ' | '\t'; v = next_int >] -> v -| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] -> - (match i with - Tint n -> n - | _ -> failwith "unexpected branch in next_int");; - -(* This is the actual lexical analyser, implemented as a function on a stream. - It will be used with the Stream.from primitive to construct a function - of type char Stream.t -> simple_token option Stream.t *) -let token_stream cs _ = - try let tok = next_token cs in - Some tok - with Stream.Failure -> None;; - -(* Two of the actions of the parser request that one reads the rest of - the input up to a specific string stop_string. This is done - with a function that transform the input_channel into a pair of - char Stream.t, reading from the input_channel all the lines to - the stop_string first. *) - - -let rec gather_strings stop_string input_channel = - let buff = input_line input_channel in - if buff = stop_string then - [] - else - (buff::(gather_strings stop_string input_channel));; - - -(* the result of this function is supposed to be used in a Stream.from - construction. *) - -let line_list_to_stream string_list = - let count = ref 0 in - let buff = ref "" in - let reserve = ref string_list in - let current_length = ref 0 in - (fun i -> if (i - !count) >= !current_length then - begin - count := !count + !current_length + 1; - match !reserve with - | [] -> None - | s1::rest -> - begin - buff := s1; - current_length := String.length !buff; - reserve := rest; - Some '\n' - end - end - else - Some(String.get !buff (i - !count)));; - - -(* In older revisions of this file you would find a function that - does line oriented breakdown of the input channel without resorting to - a list of lines. However, the need for the list of line appeared when - we wanted to have a channel and a list of strings describing the same - data, one for regular parsing and the other for error recovery. *) - -let channel_to_stream_and_string_list stop_string input_channel = - let string_list = gather_strings stop_string input_channel in - (line_list_to_stream string_list, string_list);; - -let flush_until_end_of_stream char_stream = - Stream.iter (function _ -> ()) char_stream;; - -(* There are only 5 kinds of lines recognized by our little parser. - Unrecognized lines are ignored. *) -type parser_request = - | PRINT_VERSION - | PARSE_STRING of string - (* parse_string <int> [<ident>] then text and && END--OF--DATA *) - | QUIET_PARSE_STRING - (* quiet_parse_string then text and && END--OF--DATA *) - | PARSE_FILE of string - (* parse_file <int> <string> *) - | ADD_PATH of string - (* add_path <int> <string> *) - | ADD_REC_PATH of string * string - (* add_rec_path <int> <string> <ident> *) - | LOAD_SYNTAX of string - (* load_syntax_file <int> <ident> *) - | GARBAGE -;; - -(* The procedure parser_loop should never terminate while the input_channel is - not closed. This procedure receives the functions called for each sentence - as arguments. Thus the code is completely independent from the Coq sources. *) -let parser_loop functions input_channel = - let print_version_action, - parse_string_action, - quiet_parse_string_action, - parse_file_action, - add_path_action, - add_rec_path_action, - load_syntax_action = functions in - let rec parser_loop_rec input_channel = - (let line = input_line input_channel in - let reqid, parser_request = - try - (match Stream.from (token_stream (Stream.of_string line)) with - parser - | [< 'Tid "print_version" >] -> - 0, PRINT_VERSION - | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; - 'Tid phylum ; 'Trbracket >] - -> reqid,PARSE_STRING phylum - | [< 'Tid "quiet_parse_string" >] -> - 0,QUIET_PARSE_STRING - | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] -> - reqid, PARSE_FILE fname - | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ; 'Tid alias >] - -> reqid, ADD_REC_PATH(directory, alias) - | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >] - -> reqid, ADD_PATH directory - | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] -> - reqid, LOAD_SYNTAX module_name - | [< 'Tid "quit_parser" >] -> raise End_of_file - | [< >] -> 0, GARBAGE) - with - Stream.Failure | Stream.Error _ -> 0,GARBAGE in - match parser_request with - PRINT_VERSION -> print_version_action () - | PARSE_STRING phylum -> - let regular_stream, string_list = - channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in - parse_string_action reqid phylum (Stream.from regular_stream) - string_list;() - | QUIET_PARSE_STRING -> - let regular_stream, string_list = - channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in - quiet_parse_string_action - (Stream.from regular_stream);() - | PARSE_FILE file_name -> - parse_file_action reqid file_name - | ADD_PATH path -> add_path_action reqid path - | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias - | LOAD_SYNTAX syn -> load_syntax_action reqid syn - | GARBAGE -> ()); - parser_loop_rec input_channel in - parser_loop_rec input_channel;; diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli deleted file mode 100644 index b0b043c7..00000000 --- a/contrib/interface/line_parser.mli +++ /dev/null @@ -1,5 +0,0 @@ -val parser_loop : - (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) * - (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) * - (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c -val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml deleted file mode 100644 index 0dc8f024..00000000 --- a/contrib/interface/name_to_ast.ml +++ /dev/null @@ -1,232 +0,0 @@ -open Sign;; -open Classops;; -open Names;; -open Nameops -open Term;; -open Impargs;; -open Reduction;; -open Libnames;; -open Libobject;; -open Environ;; -open Declarations;; -open Prettyp;; -open Inductive;; -open Util;; -open Pp;; -open Declare;; -open Nametab -open Vernacexpr;; -open Decl_kinds;; -open Constrextern;; -open Topconstr;; - -(* This function converts the parameter binders of an inductive definition, - in particular you have to be careful to handle each element in the - context containing all previously defined variables. This squeleton - of this procedure is taken from the function print_env in pretty.ml *) -let convert_env = - let convert_binder env (na, b, c) = - match b with - | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) - | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in - let rec cvrec env = function - [] -> [] - | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in - cvrec (Global.env());; - -(* let mib string = - let sp = Nametab.sp_of_id CCI (id_of_string string) in - let lobj = Lib.map_leaf (objsp_of sp) in - let (cmap, _) = outMutualInductive lobj in - Listmap.map cmap CCI;; *) - -(* This function is directly inspired by print_impl_args in pretty.ml *) - -let impl_args_to_string_by_pos = function - [] -> None - | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.") - | l -> Some (" positions " ^ - (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s) - l - " are implicit."));; - -(* This function is directly inspired by implicit_args_id in pretty.ml *) - -let impl_args_to_string l = - impl_args_to_string_by_pos (positions_of_implicits l) - -let implicit_args_id_to_ast_list id l ast_list = - (match impl_args_to_string l with - None -> ast_list - | Some(s) -> CommentString s:: - CommentString ("For " ^ (string_of_id id)):: - ast_list);; - -(* This function construct an ast to enumerate the implicit positions for an - inductive type and its constructors. It is obtained directly from - implicit_args_msg in pretty.ml. *) - -let implicit_args_to_ast_list sp mipv = - let implicit_args_descriptions = - let ast_list = ref [] in - (Array.iteri - (fun i mip -> - let imps = implicits_of_global (IndRef (sp, i)) in - (ast_list := - implicit_args_id_to_ast_list mip.mind_typename imps !ast_list; - Array.iteri - (fun j idc -> - let impls = implicits_of_global - (ConstructRef ((sp,i),j+1)) in - ast_list := - implicit_args_id_to_ast_list idc impls !ast_list) - mip.mind_consnames)) - mipv; - !ast_list) in - match implicit_args_descriptions with - [] -> [] - | _ -> [VernacComments (List.rev implicit_args_descriptions)];; - -(* This function converts constructors for an inductive definition to a - Coqast.t. It is obtained directly from print_constructors in pretty.ml *) - -let convert_constructors envpar names types = - let array_idC = - array_map2 - (fun n t -> - let coercion_flag = false (* arbitrary *) in - (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) - names types in - Array.to_list array_idC;; - -(* this function converts one inductive type in a possibly multiple inductive - definition *) - -let convert_one_inductive sp tyi = - let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in - let env = Global.env () in - let envpar = push_rel_context params env in - let sp = sp_of_global (IndRef (sp, tyi)) in - (((false,(dummy_loc,basename sp)), - convert_env(List.rev params), - Some (extern_constr true envpar arity), Vernacexpr.Inductive_kw , - Constructors (convert_constructors envpar cstrnames cstrtypes)), None);; - -(* This function converts a Mutual inductive definition to a Coqast.t. - It is obtained directly from print_mutual in pretty.ml. However, all - references to kinds have been removed and it treats only CCI stuff. *) - -let mutual_to_ast_list sp mib = - let mipv = (Global.lookup_mind sp).mind_packets in - let _, l = - Array.fold_right - (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in - VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), l) - :: (implicit_args_to_ast_list sp mipv);; - -let constr_to_ast v = - extern_constr true (Global.env()) v;; - -let implicits_to_ast_list implicits = - match (impl_args_to_string implicits) with - | None -> [] - | Some s -> [VernacComments [CommentString s]];; - -let make_variable_ast name typ implicits = - (VernacAssumption - ((Local,Definitional),false,(*inline flag*) - [false,([dummy_loc,name], constr_to_ast typ)])) - ::(implicits_to_ast_list implicits);; - - -let make_definition_ast name c typ implicits = - VernacDefinition ((Global,false,Definition), (dummy_loc,name), - DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)), - (fun _ _ -> ())) - ::(implicits_to_ast_list implicits);; - -(* This function is inspired by print_constant *) -let constant_to_ast_list kn = - let cb = Global.lookup_constant kn in - let c = cb.const_body in - let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in - let l = implicits_of_global (ConstRef kn) in - (match c with - None -> - make_variable_ast (id_of_label (con_label kn)) typ l - | Some c1 -> - make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) - -let variable_to_ast_list sp = - let (id, c, v) = Global.lookup_named sp in - let l = implicits_of_global (VarRef sp) in - (match c with - None -> - make_variable_ast id v l - | Some c1 -> - make_definition_ast id c1 v l);; - -(* this function is taken from print_inductive in file pretty.ml *) - -let inductive_to_ast_list sp = - let mib = Global.lookup_mind sp in - mutual_to_ast_list sp mib - -(* this function is inspired by print_leaf_entry from pretty.ml *) - -let leaf_entry_to_ast_list ((sp,kn),lobj) = - let tag = object_tag lobj in - match tag with - | "VARIABLE" -> variable_to_ast_list (basename sp) - | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) - | "INDUCTIVE" -> inductive_to_ast_list kn - | s -> - errorlabstrm - "print" (str ("printing of unrecognized object " ^ - s ^ " has been required"));; - - - - -(* this function is inspired by print_name *) -let name_to_ast ref = - let (loc,qid) = qualid_of_reference ref in - let l = - try - let sp = Nametab.locate_obj qid in - let (sp,lobj) = - let (sp,entry) = - List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None) - in - match entry with - | Lib.Leaf obj -> (sp,obj) - | _ -> raise Not_found - in - leaf_entry_to_ast_list (sp,lobj) - with Not_found -> - try - match Nametab.locate qid with - | ConstRef sp -> constant_to_ast_list sp - | IndRef (sp,_) -> inductive_to_ast_list sp - | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp - | VarRef sp -> variable_to_ast_list sp - with Not_found -> - try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,name = repr_qualid qid in - if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named name in - (match c with - None -> make_variable_ast name typ [] - | Some c1 -> make_definition_ast name c1 typ []) - with Not_found -> - try - let _sp = Nametab.locate_syntactic_definition qid in - errorlabstrm "print" - (str "printing of syntax definitions not implemented") - with Not_found -> - errorlabstrm "print" - (pr_qualid qid ++ - spc () ++ str "not a defined object") - in - VernacList (List.map (fun x -> (dummy_loc,x)) l) - diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli deleted file mode 100644 index f9e83b5e..00000000 --- a/contrib/interface/name_to_ast.mli +++ /dev/null @@ -1,5 +0,0 @@ -val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; -val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;; -val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;; -val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;; -val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml deleted file mode 100644 index 1bbab5fe..00000000 --- a/contrib/interface/parse.ml +++ /dev/null @@ -1,422 +0,0 @@ -open Util;; -open System;; -open Pp;; -open Libnames;; -open Library;; -open Ascent;; -open Vtp;; -open Xlate;; -open Line_parser;; -open Pcoq;; -open Vernacexpr;; -open Mltop;; - -type parsed_tree = - | P_cl of ct_COMMAND_LIST - | P_c of ct_COMMAND - | P_t of ct_TACTIC_COM - | P_f of ct_FORMULA - | P_id of ct_ID - | P_s of ct_STRING - | P_i of ct_INT;; - -let print_parse_results n msg = - Pp.msg - ( str "message\nparsed\n" ++ - int n ++ - str "\n" ++ - (match msg with - | P_cl x -> fCOMMAND_LIST x - | P_c x -> fCOMMAND x - | P_t x -> fTACTIC_COM x - | P_f x -> fFORMULA x - | P_id x -> fID x - | P_s x -> fSTRING x - | P_i x -> fINT x) ++ - str "e\nblabla\n"); - flush stdout;; - -let ctf_SyntaxErrorMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++ - int reqid ++ fnl () ++ - pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; -let ctf_SyntaxWarningMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++ - int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; - -let ctf_FileErrorMessage reqid pps = - fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++ - int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ - fnl ();; - -let execute_when_necessary v = - (match v with - | VernacOpenCloseScope sc -> Vernacentries.interp v - | VernacRequire (_,_,l) -> - (try - Vernacentries.interp v - with _ -> - let l=prlist_with_sep spc pr_reference l in - msgnl (str "Reinterning of " ++ l ++ str " failed")) - | VernacRequireFrom (_,_,f) -> - (try - Vernacentries.interp v - with _ -> - msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) - | _ -> ()); v;; - -let parse_to_dot = - let rec dot st = match Stream.next st with - | ("", ".") -> () - | ("EOI", "") -> raise End_of_file - | _ -> dot st in - Gram.Entry.of_parser "Coqtoplevel.dot" dot;; - -let rec discard_to_dot stream = - try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with - | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;; - -let rec decompose_string_aux s n = - try let index = String.index_from s n '\n' in - (String.sub s n (index - n)):: - (decompose_string_aux s (index + 1)) - with Not_found -> [String.sub s n ((String.length s) - n)];; - -let decompose_string s n = - match decompose_string_aux s n with - ""::tl -> tl - | a -> a;; - -let make_string_list file_chan fst_pos snd_pos = - let len = (snd_pos - fst_pos) in - let s = String.create len in - begin - seek_in file_chan fst_pos; - really_input file_chan s 0 len; - decompose_string s 0; - end;; - -let rec get_sub_aux string_list snd_pos = - match string_list with - [] -> [] - | s::l -> - let len = String.length s in - if len >= snd_pos then - if snd_pos < 0 then - [] - else - [String.sub s 0 snd_pos] - else - s::(get_sub_aux l (snd_pos - len - 1));; - -let rec get_substring_list string_list fst_pos snd_pos = - match string_list with - [] -> [] - | s::l -> - let len = String.length s in - if fst_pos > len then - get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) - else - (* take into account the fact that carriage returns are not in the *) - (* strings. *) - let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in - if snd_pos > len then - String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2):: - (get_sub_aux l (snd_pos - len - 2)) - else - let gap = (snd_pos - fst_pos2) in - if gap < 0 then - [] - else - [String.sub s (fst_pos2 - 1) gap];; - -(* When parsing a list of commands, we try to recover error messages for - each individual command. *) - -type parse_result = - | ParseOK of Vernacexpr.vernac_expr located option - | ParseError of string * string list - -let embed_string s = - CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s)) - -let make_parse_error_item s l = - CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l)) - -let parse_command_list reqid stream string_list = - let rec parse_whole_stream () = - let this_pos = Stream.count stream in - let first_ast = - try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) - with - | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> - begin - msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); - try - discard_to_dot stream; - msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ - int (Stream.count stream)); - ParseError ("PARSING_ERROR", - get_substring_list string_list this_pos - (Stream.count stream)) - with End_of_file -> ParseOK None - end - | e-> - begin - discard_to_dot stream; - ParseError ("PARSING_ERROR2", - get_substring_list string_list this_pos (Stream.count stream)) - end in - match first_ast with - | ParseOK (Some (loc,ast)) -> - let _ast0 = (execute_when_necessary ast) in - (try xlate_vernac ast - with e -> - make_parse_error_item "PARSING_ERROR2" - (get_substring_list string_list this_pos - (Stream.count stream)))::parse_whole_stream() - | ParseOK None -> [] - | ParseError (s,l) -> - (make_parse_error_item s l)::parse_whole_stream() - in - match parse_whole_stream () with - | first_one::tail -> (P_cl (CT_command_list(first_one, tail))) - | [] -> raise (UserError ("parse_string", (str "empty text.")));; - -(*When parsing a string using a phylum, the string is first transformed - into a Coq Ast using the regular Coq parser, then it is transformed into - the right ascent term using xlate functions, then it is transformed into - a stream, using the right vtp function. There is a special case for commands, - since some of these must be executed!*) -let parse_string_action reqid phylum char_stream string_list = - try let msg = - match phylum with - | "COMMAND_LIST" -> - parse_command_list reqid char_stream string_list - | "COMMAND" -> - P_c - (xlate_vernac - (execute_when_necessary - (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) - | "TACTIC_COM" -> - P_t - (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi - (Gram.parsable char_stream))) - | "FORMULA" -> - P_f - (xlate_formula - (Gram.Entry.parse - (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) - | "ID" -> P_id (CT_ident - (Libnames.string_of_qualid - (snd - (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) - (Gram.parsable char_stream))))) - | "STRING" -> - P_s - (CT_string (Gram.Entry.parse Pcoq.Prim.string - (Gram.parsable char_stream))) - | "INT" -> - P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural - (Gram.parsable char_stream))) - | _ -> error "parse_string_action : bad phylum" in - print_parse_results reqid msg - with - | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> - flush_until_end_of_stream char_stream; - msgnl (ctf_SyntaxErrorMessage reqid - (Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error "match failure")))) - | e -> - flush_until_end_of_stream char_stream; - msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));; - - -let quiet_parse_string_action char_stream = - try let _ = - Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in - () - with - | _ -> flush_until_end_of_stream char_stream; ();; - - -let parse_file_action reqid file_name = - try let file_chan = open_in file_name in - (* file_chan_err, stream_err are the channel and stream used to - get the text when a syntax error occurs *) - let file_chan_err = open_in file_name in - let stream = Stream.of_channel file_chan in - let _stream_err = Stream.of_channel file_chan_err in - let rec discard_to_dot () = - try Gram.Entry.parse parse_to_dot (Gram.parsable stream) - with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in - match let rec parse_whole_file () = - let this_pos = Stream.count stream in - match - try - ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) - with - | Stdpp.Exc_located(l,Stream.Error txt) -> - msgnl (ctf_SyntaxWarningMessage reqid - (str "Error with file" ++ spc () ++ - str file_name ++ fnl () ++ - Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error txt)))); - (try - begin - discard_to_dot (); - ParseError ("PARSING_ERROR", - (make_string_list file_chan_err this_pos - (Stream.count stream))) - end - with End_of_file -> ParseOK None) - | e -> - begin - Gram.Entry.parse parse_to_dot (Gram.parsable stream); - ParseError ("PARSING_ERROR2", - (make_string_list file_chan this_pos - (Stream.count stream))) - end - - with - | ParseOK (Some (_,ast)) -> - let _ast0=(execute_when_necessary ast) in - let term = - (try xlate_vernac ast - with e -> - print_string ("translation error between " ^ - (string_of_int this_pos) ^ - " " ^ - (string_of_int (Stream.count stream)) ^ - "\n"); - make_parse_error_item "PARSING_ERROR2" - (make_string_list file_chan_err this_pos - (Stream.count stream))) in - term::parse_whole_file () - | ParseOK None -> [] - | ParseError (s,l) -> - (make_parse_error_item s l)::parse_whole_file () in - parse_whole_file () with - | first_one :: tail -> - print_parse_results reqid - (P_cl (CT_command_list (first_one, tail))) - | [] -> raise (UserError ("parse_file_action", str "empty file.")) - with - | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> - msgnl - (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ - fnl () ++ - Cerrors.explain_exn - (Stdpp.Exc_located(l,Stream.Error "match failure")))) - | e -> - msgnl - (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ - fnl () ++ Cerrors.explain_exn e));; - -let add_rec_path_action reqid string_arg ident_arg = - let directory_name = expand_path_macros string_arg in - begin - add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) - end;; - - -let add_path_action reqid string_arg = - let directory_name = expand_path_macros string_arg in - begin - add_path directory_name Names.empty_dirpath - end;; - -let print_version_action () = - msgnl (mt ()); - msgnl (str "$Id: parse.ml 11749 2009-01-05 14:01:04Z notin $");; - -let load_syntax_action reqid module_name = - msg (str "loading " ++ str module_name ++ str "... "); - try - (let qid = Libnames.make_short_qualid (Names.id_of_string module_name) in - require_library [dummy_loc,qid] None; - msg (str "opening... "); - Declaremods.import_module false (Nametab.locate_module qid); - msgnl (str "done" ++ fnl ()); - ()) - with - | UserError (label, pp_stream) -> - (*This one may be necessary to make sure that the message won't be indented *) - msgnl (mt ()); - msgnl - (fnl () ++ str "error while loading syntax module " ++ str module_name ++ - str ": " ++ str label ++ fnl () ++ pp_stream) - | e -> - msgnl (mt ()); - msgnl - (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++ - int reqid ++ fnl ()); - ();; - -let coqparser_loop inchan = - (parser_loop : (unit -> unit) * - (int -> string -> char Stream.t -> string list -> unit) * - (char Stream.t -> unit) * (int -> string -> unit) * - (int -> string -> unit) * (int -> string -> string -> unit) * - (int -> string -> unit) -> in_channel -> unit) - (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action, - add_path_action, add_rec_path_action, load_syntax_action) inchan;; - -if !Sys.interactive then () - else -Libobject.relax true; -(let coqdir = - try Sys.getenv "COQDIR" - with Not_found -> - let coqdir = Envars.coqlib () in - if Sys.file_exists coqdir then - coqdir - else - (msgnl (str "could not find the value of COQDIR"); exit 1) in - begin - add_rec_path (Filename.concat coqdir "theories") - (Names.make_dirpath [Nameops.coq_root]); - add_rec_path (Filename.concat coqdir "contrib") - (Names.make_dirpath [Nameops.coq_root]) - end; -(let vernacrc = - try - Sys.getenv "VERNACRC" - with - Not_found -> - List.fold_left - (fun s1 s2 -> (Filename.concat s1 s2)) - coqdir [ "contrib"; "interface"; "vernacrc"] in - try - (Gramext.warning_verbose := false; - coqparser_loop (open_in vernacrc)) - with - | End_of_file -> () - | e -> - (msgnl (Cerrors.explain_exn e); - msgnl (str "could not load the VERNACRC file")); - try - msgnl (str vernacrc) - with - e -> ()); -(try let user_vernacrc = - try Some(Sys.getenv "USERVERNACRC") - with - | Not_found -> - msgnl (str "no .vernacrc file"); None in - (match user_vernacrc with - Some f -> coqparser_loop (open_in f) - | None -> ()) - with - | End_of_file -> () - | e -> - msgnl (Cerrors.explain_exn e); - msgnl (str "error in your .vernacrc file")); -msgnl (str "Starting Centaur Specialized Parser Loop"); -try - coqparser_loop stdin -with - | End_of_file -> () - | e -> msgnl(Cerrors.explain_exn e)) diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml deleted file mode 100644 index a157ca92..00000000 --- a/contrib/interface/paths.ml +++ /dev/null @@ -1,26 +0,0 @@ -let int_list_to_string s l = - List.fold_left - (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) - s - l;; - -(* Given two paths, this function returns the longest common prefix and the - two suffixes. *) -let rec decompose_path - : (int list * int list) -> (int list * int list * int list) = - function - (a::l,b::m) when a = b -> - let (c,p1,p2) = decompose_path (l,m) in - (a::c,p1,p2) - | p1,p2 -> [], p1, p2;; - -let rec is_prefix p1 p2 = match p1,p2 with - [], _ -> true -| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2 -| _ -> false;; - -let rec lex_smaller p1 p2 = match p1,p2 with - [], _ -> true -| a::tl1, b::tl2 when a < b -> true -| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 -| _ -> false;; diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli deleted file mode 100644 index 26620723..00000000 --- a/contrib/interface/paths.mli +++ /dev/null @@ -1,4 +0,0 @@ -val decompose_path : (int list * int list) -> (int list * int list * int list);; -val int_list_to_string : string -> int list -> string;; -val is_prefix : int list -> int list -> bool;; -val lex_smaller : int list -> int list -> bool;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml deleted file mode 100644 index 01747aa5..00000000 --- a/contrib/interface/pbp.ml +++ /dev/null @@ -1,758 +0,0 @@ -(* A proof by pointing algorithm. *) -open Util;; -open Names;; -open Term;; -open Tactics;; -open Tacticals;; -open Hipattern;; -open Pattern;; -open Matching;; -open Reduction;; -open Rawterm;; -open Environ;; - -open Proof_trees;; -open Proof_type;; -open Tacmach;; -open Tacexpr;; -open Typing;; -open Pp;; -open Libnames;; -open Genarg;; -open Topconstr;; -open Termops;; - -let zz = Util.dummy_loc;; - -let hyp_radix = id_of_string "H";; - -let next_global_ident = next_global_ident_away true - -(* get_hyp_by_name : goal sigma -> string -> constr, - looks up for an hypothesis (or a global constant), from its name *) -let get_hyp_by_name g name = - let evd = project g in - let env = pf_env g in - try (let judgment = - Pretyping.Default.understand_judgment - evd env (RVar(zz, name)) in - ("hyp",judgment.uj_type)) -(* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... - Loïc *) - with _ -> (let c = Nametab.global (Ident (zz,name)) in - ("cste",type_of (Global.env()) Evd.empty (constr_of_global c))) -;; - -type pbp_atom = - | PbpTryAssumption of identifier option - | PbpTryClear of identifier list - | PbpGeneralize of identifier * identifier list - | PbpLApply of identifier (* = CutAndApply *) - | PbpIntros of intro_pattern_expr located list - | PbpSplit - (* Existential *) - | PbpExists of identifier - (* Or *) - | PbpLeft - | PbpRight - (* Head *) - | PbpApply of identifier - | PbpElim of identifier * identifier list;; - -(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics - [a1]..[an-1] are atomic (or try of an atomic) tactic and produce - exactly one goal, and [an] produces exactly p subgoals - - In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and - produces exactly one subgoal, except the last one which may complete the - goal - - Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion - from atomic to composed tactic -*) - -type pbp_sequence = - | PbpThens of pbp_atom list * pbp_sequence list - | PbpThen of pbp_atom list - -(* This flattens sequences of tactics producing just one subgoal *) -let chain_tactics tl1 = function - | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3) - | PbpThen tl2 -> PbpThen (tl1@tl2) - -type pbp_rule = (identifier list * - identifier list * - bool * - identifier option * - (types, constr) kind_of_term * - int list * - (identifier list -> - identifier list -> - bool -> - identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) -> - pbp_sequence option;; - - -let make_named_intro id = PbpIntros [zz,IntroIdentifier id];; - -let make_clears str_list = PbpThen [PbpTryClear str_list] - -let add_clear_names_if_necessary tactic clear_names = - match clear_names with - [] -> tactic - | l -> chain_tactics [PbpTryClear l] tactic;; - -let make_final_cmd f optname clear_names constr path = - add_clear_names_if_necessary (f optname constr path) clear_names;; - -let (rem_cast:pbp_rule) = function - (a,c,cf,o, Cast(f,_,_), p, func) -> - Some(func a c cf o (kind_of_term f) p) - | _ -> None;; - -let (forall_intro: pbp_rule) = function - (avoid, - clear_names, - clear_flag, - None, - Prod(Name x, _, body), - (2::path), - f) -> - let x' = next_global_ident x avoid in - Some(chain_tactics [make_named_intro x'] - (f (x'::avoid) - clear_names clear_flag None (kind_of_term body) path)) -| _ -> None;; - -let (imply_intro2: pbp_rule) = function - avoid, clear_names, - clear_flag, None, Prod(Anonymous, _, body), 2::path, f -> - let h' = next_global_ident hyp_radix avoid in - Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) - | _ -> None;; - - -(* -let (imply_intro1: pbp_rule) = function - avoid, clear_names, - clear_flag, None, Prod(Anonymous, prem, body), 1::path, f -> - let h' = next_global_ident hyp_radix avoid in - let str_h' = h' in - Some(chain_tactics [make_named_intro str_h'] - (f (h'::avoid) clear_names clear_flag (Some str_h') - (kind_of_term prem) path)) - | _ -> None;; -*) - -let make_var id = CRef (Ident(zz, id)) - -let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l) - -let make_pbp_pattern x = - make_app (make_var (id_of_string "PBP_META")) - [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] - -let rec make_then = function - | [] -> TacId [] - | [t] -> t - | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l) - -let make_pbp_atomic_tactic = function - | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) - | PbpTryAssumption (Some a) -> - TacTry (TacAtom (zz, TacExact (make_var a))) - | PbpExists x -> - TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x])) - | PbpGeneralize (h,args) -> - let l = List.map make_pbp_pattern args in - TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous]) - | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings)) - | PbpRight -> TacAtom (zz, TacRight (false,NoBindings)) - | PbpIntros l -> TacAtom (zz, TacIntroPattern l) - | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) - | PbpApply h -> TacAtom (zz, TacApply (true,false,[make_var h,NoBindings],None)) - | PbpElim (hyp_name, names) -> - let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in - TacAtom - (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None)) - | PbpTryClear l -> - TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) - | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));; - -let rec make_pbp_tactic = function - | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl) - | PbpThens (l,tl) -> - TacThens - (make_then (List.map make_pbp_atomic_tactic l), - List.map make_pbp_tactic tl) - -let (forall_elim: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Name x, _, body), 2::path, f -> - let h' = next_global_ident hyp_radix avoid in - let clear_names' = if clear_flag then h::clear_names else clear_names in - Some - (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h'] - (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path)) - | _ -> None;; - - -let (imply_elim1: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Anonymous, prem, body), 1::path, f -> - let clear_names' = if clear_flag then h::clear_names else clear_names in - let h' = next_global_ident hyp_radix avoid in - let _str_h' = (string_of_id h') in - Some(PbpThens - ([PbpLApply h], - [chain_tactics [make_named_intro h'] (make_clears (h::clear_names)); - f avoid clear_names' false None (kind_of_term prem) path])) - | _ -> None;; - - -let (imply_elim2: pbp_rule) = function - avoid, clear_names, clear_flag, - Some h, Prod(Anonymous, prem, body), 2::path, f -> - let clear_names' = if clear_flag then h::clear_names else clear_names in - let h' = next_global_ident hyp_radix avoid in - Some(PbpThens - ([PbpLApply h], - [chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names' false (Some h') - (kind_of_term body) path); - make_clears clear_names])) - | _ -> None;; - -let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s - -let constant dir s = Coqlib.gen_constant "Pbp" ("Init"::dir) s - -let andconstr: unit -> constr = Coqlib.build_coq_and;; -let prodconstr () = constant ["Datatypes"] "prod";; -let exconstr = Coqlib.build_coq_ex;; -let sigconstr () = constant ["Specif"] "sig";; -let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;; -let orconstr = Coqlib.build_coq_or;; -let sumboolconstr = Coqlib.build_coq_sumbool;; -let sumconstr() = constant ["Datatypes"] "sum";; -let notconstr = Coqlib.build_coq_not;; -let notTconstr () = constant ["Logic_Type"] "notT";; - -let is_matching_local a b = is_matching (pattern_of_constr a) b;; - -let rec (or_and_tree_to_intro_pattern: identifier list -> - constr -> int list -> - intro_pattern_expr * identifier list * identifier *constr - * int list * int * int) = -fun avoid c path -> match kind_of_term c, path with - | (App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (andconstr()) oper) or - (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> - let id2 = next_global_ident hyp_radix avoid in - let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let patt_list = - if a = 1 then - [zz,cont_patt; zz,IntroIdentifier id2] - else - [zz,IntroIdentifier id2; zz,cont_patt] in - (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, - total_branches) - | (App(oper, [|c1; c2|]), 2::3::path) - when ((is_matching_local (exconstr()) oper) or - (is_matching_local (sigconstr()) oper)) -> - (match (kind_of_term c2) with - Lambda (Name x, _, body) -> - let id1 = next_global_ident x avoid in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id1::avoid) body path in - (IntroOrAndPattern[[zz,IntroIdentifier id1; zz,cont_patt]], - avoid_names, id, c, path, rank, total_branches) - | _ -> assert false) - | (App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (orconstr ()) oper) or - (is_matching_local (sumboolconstr ()) oper) or - (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) -> - let id2 = next_global_ident hyp_radix avoid in - let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = - or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let new_rank = if a = 1 then rank else rank+1 in - let patt_list = - if a = 1 then - [[zz,cont_patt];[zz,IntroIdentifier id2]] - else - [[zz,IntroIdentifier id2];[zz,cont_patt]] in - (IntroOrAndPattern patt_list, - avoid_names, id, c, path, new_rank, total_branches+1) - | (_, path) -> let id = next_global_ident hyp_radix avoid in - (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; - -let auxiliary_goals clear_names clear_flag this_name n_aux others = - let clear_cmd = - make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in - let rec clear_list = function - 0 -> others - | n -> clear_cmd::(clear_list (n - 1)) in - clear_list n_aux;; - - -let (imply_intro3: pbp_rule) = function - avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body), - 1::path, f -> - let intro_patt, avoid_names, id, c, p, rank, total_branches = - or_and_tree_to_intro_pattern avoid prem path in - if total_branches = 1 then - Some(chain_tactics [PbpIntros [zz,intro_patt]] - (f avoid_names clear_names clear_flag (Some id) - (kind_of_term c) path)) - else - Some - (PbpThens - ([PbpIntros [zz,intro_patt]], - auxiliary_goals clear_names clear_flag id - (rank - 1) - ((f avoid_names clear_names clear_flag (Some id) - (kind_of_term c) path):: - auxiliary_goals clear_names clear_flag id - (total_branches - rank) []))) - | _ -> None;; - - - -let (and_intro: pbp_rule) = function - avoid, clear_names, clear_flag, - None, App(and_oper, [|c1; c2|]), 2::a::path, f - -> - if ((is_matching_local (andconstr()) and_oper) or - (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then - let cont_term = if a = 1 then c1 else c2 in - let cont_cmd = f avoid clear_names false None - (kind_of_term cont_term) path in - let clear_cmd = make_clears clear_names in - let cmds = - (if a = 1 - then [cont_cmd;clear_cmd] - else [clear_cmd;cont_cmd]) in - Some (PbpThens ([PbpSplit],cmds)) - else None - | _ -> None;; - -let exists_from_lambda avoid clear_names clear_flag c2 path f = - match kind_of_term c2 with - Lambda(Name x, _, body) -> - Some (PbpThens ([PbpExists x], - [f avoid clear_names false None (kind_of_term body) path])) - | _ -> None;; - - -let (ex_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(oper, [| c1; c2|]), 2::3::path, f - when (is_matching_local (exconstr ()) oper) - or (is_matching_local (sigconstr ()) oper) -> - exists_from_lambda avoid clear_names clear_flag c2 path f - | _ -> None;; - -let (exT_intro : pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(oper, [| c1; c2|]), 2::2::2::path, f - when (is_matching_local (sigTconstr ()) oper) -> - exists_from_lambda avoid clear_names clear_flag c2 path f - | _ -> None;; - -let (or_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(or_oper, [|c1; c2 |]), 2::a::path, f -> - if ((is_matching_local (orconstr ()) or_oper) or - (is_matching_local (sumboolconstr ()) or_oper) or - (is_matching_local (sumconstr ()) or_oper)) - & (a = 1 or a = 2) then - let cont_term = if a = 1 then c1 else c2 in - let fst_cmd = if a = 1 then PbpLeft else PbpRight in - let cont_cmd = f avoid clear_names false None - (kind_of_term cont_term) path in - Some(chain_tactics [fst_cmd] cont_cmd) - else - None - | _ -> None;; - -let dummy_id = id_of_string "Dummy";; - -let (not_intro: pbp_rule) = function - avoid, clear_names, clear_flag, None, - App(not_oper, [|c1|]), 2::1::path, f -> - if(is_matching_local (notconstr ()) not_oper) or - (is_matching_local (notTconstr ()) not_oper) then - let h' = next_global_ident hyp_radix avoid in - Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names false (Some h') - (kind_of_term c1) path)) - else - None - | _ -> None;; - - - - -let elim_with_bindings hyp_name names = - PbpElim (hyp_name, names);; - -(* This function is used to follow down a path, while staying on the spine of - successive products (universal quantifications or implications). - Arguments are the current observed constr object and the path that remains - to be followed, and an integer indicating how many products have already been - crossed. - Result is: - - a list of string indicating the names of universally quantified variables. - - a list of integers indicating the positions of the successive - universally quantified variables. - - an integer indicating the number of non-dependent products. - - the last constr object encountered during the walk down, and - - the remaining path. - - For instance the following session should happen: - let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign())) - (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in - down_prods (tt, [2;2;2], 0) - ---> ["P","x"],[0;1], 1, <<(P x)>>, [] -*) - - -let rec down_prods: (types, constr) kind_of_term * (int list) * int -> - identifier list * (int list) * int * (types, constr) kind_of_term * - (int list) = - function - Prod(Name x, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p - = down_prods (kind_of_term body, path, k+1) in - x::res_sl, (k::res_il), res_i, res_cstr, res_p - | Prod(Anonymous, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p - = down_prods (kind_of_term body, path, k+1) in - res_sl, res_il, res_i+1, res_cstr, res_p - | cstr, path, _ -> [], [], 0, cstr, path;; - -exception Pbp_internal of int list;; - -(* This function should be usable to check that a type can be used by the - Apply command. Basically, c is supposed to be the head of some - type, where l gives the ranks of all universally quantified variables. - It check that these universally quantified variables occur in the head. - - The knowledge I have on constr structures is incomplete. -*) -let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = - function c -> function l -> - let rec delete n = function - | [] -> [] - | p::tl -> if n = p then tl else p::(delete n tl) in - let rec check_rec l = function - | App(f, array) -> - Array.fold_left (fun l c -> check_rec l (kind_of_term c)) - (check_rec l (kind_of_term f)) array - | Const _ -> l - | Ind _ -> l - | Construct _ -> l - | Var _ -> l - | Rel p -> - let result = delete p l in - if result = [] then - raise (Pbp_internal []) - else - result - | _ -> raise (Pbp_internal l) in - try - (check_rec l c) = [] - with Pbp_internal l -> l = [];; - -let (mk_db_indices: int list -> int -> int list) = - function int_list -> function nprems -> - let total = (List.length int_list) + nprems in - let rec mk_db_aux = function - [] -> [] - | a::l -> (total - a)::(mk_db_aux l) in - mk_db_aux int_list;; - - -(* This proof-by-pointing rule is quite complicated, as it attempts to foresee - usages of head tactics. A first operation is to follow the path as far - as possible while staying on the spine of products (function down_prods) - and then to check whether the next step will be an elim step. If the - answer is true, then the built command takes advantage of the power of - head tactics. *) - -let (head_tactic_patt: pbp_rule) = function - avoid, clear_names, clear_flag, Some h, cstr, path, f -> - (match down_prods (cstr, path, 0) with - | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path) - when (((is_matching_local (exconstr ()) oper) (* or - (is_matching_local (sigconstr ()) oper) *)) && a = 3) -> - (match (kind_of_term c2) with - Lambda(Name x, _,body) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let x' = next_global_ident x avoid in - let cont_body = - Prod(Name x', c1, - mkProd(Anonymous, body, - mkVar(dummy_id))) in - let cont_tac - = f avoid (h::clear_names) false None - cont_body (2::1::path) in - cont_tac::(auxiliary_goals - clear_names clear_flag - h nprems []))) - | _ -> None) - | (str_list, _, nprems, - App(oper,[|c1|]), 2::1::path) - when - (is_matching_local (notconstr ()) oper) or - (is_matching_local (notTconstr ()) oper) -> - Some(chain_tactics [elim_with_bindings h str_list] - (f avoid clear_names false None (kind_of_term c1) path)) - | (str_list, _, nprems, - App(oper, [|c1; c2|]), 2::a::path) - when ((is_matching_local (andconstr()) oper) or - (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> - let h1 = next_global_ident hyp_radix avoid in - let h2 = next_global_ident hyp_radix (h1::avoid) in - Some(PbpThens - ([elim_with_bindings h str_list], - let cont_body = - if a = 1 then c1 else c2 in - let cont_tac = - f (h2::h1::avoid) (h::clear_names) - false (Some (if 1 = a then h1 else h2)) - (kind_of_term cont_body) path in - (chain_tactics - [make_named_intro h1; make_named_intro h2] - cont_tac):: - (auxiliary_goals clear_names clear_flag h nprems []))) - | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) - when ((is_matching_local (sigTconstr()) oper)) & a = 2 -> - (match (kind_of_term c2),path with - Lambda(Name x, _,body), (2::path) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let x' = next_global_ident x avoid in - let cont_body = - Prod(Name x', c1, - mkProd(Anonymous, body, - mkVar(dummy_id))) in - let cont_tac - = f avoid (h::clear_names) false None - cont_body (2::1::path) in - cont_tac::(auxiliary_goals - clear_names clear_flag - h nprems []))) - | _ -> None) - | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) - when ((is_matching_local (orconstr ()) oper) or - (is_matching_local (sumboolconstr ()) oper) or - (is_matching_local (sumconstr ()) oper)) & - (a = 1 or a = 2) -> - Some(PbpThens - ([elim_with_bindings h str_list], - let cont_body = - if a = 1 then c1 else c2 in - (* h' is the name for the new intro *) - let h' = next_global_ident hyp_radix avoid in - let cont_tac = - chain_tactics - [make_named_intro h'] - (f - (* h' should not be used again *) - (h'::avoid) - (* the disjunct itself can be discarded *) - (h::clear_names) false (Some h') - (kind_of_term cont_body) path) in - let snd_tac = - chain_tactics - [make_named_intro h'] - (make_clears (h::clear_names)) in - let tacs1 = - if a = 1 then - [cont_tac; snd_tac] - else - [snd_tac; cont_tac] in - tacs1@(auxiliary_goals (h::clear_names) - false dummy_id nprems []))) - | (str_list, int_list, nprems, c, []) - when (check_apply c (mk_db_indices int_list nprems)) & - (match c with Prod(_,_,_) -> false - | _ -> true) & - (List.length int_list) + nprems > 0 -> - Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) - | _ -> None) - | _ -> None;; - - -let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; - forall_elim; imply_intro3; imply_elim1; imply_elim2; - and_intro; or_intro; not_intro; ex_intro; exT_intro];; - - -let try_trace = ref true;; - -let traced_try (f1:tactic) g = - try (try_trace := true; tclPROGRESS f1 g) - with e when Logic.catchable_exception e -> - (try_trace := false; tclIDTAC g);; - -let traced_try_entry = function - [Tacexp t] -> - traced_try (Tacinterp.interp t) - | _ -> failwith "traced_try_entry received wrong arguments";; - - -(* When the recursive descent along the path is over, one includes the - command requested by the point-and-shoot strategy. Default is - Try Assumption--Try Exact. *) - - -let default_ast optname constr path = PbpThen [PbpTryAssumption optname] - -(* This is the main proof by pointing function. *) -(* avoid: les noms a ne pas utiliser *) -(* final_cmd: la fonction appelee par defaut *) -(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *) - -let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = - let rec try_all_rules rl = - match rl with - f::tl -> - (match f (avoid, clear_names, clear_flag, - opt_name, constr, path, pbpt final_cmd) with - Some(ast) -> ast - | None -> try_all_rules tl) - | [] -> make_final_cmd final_cmd opt_name clear_names constr path - in try_all_rules (!pbp_rules);; - -(* these are the optimisation functions. *) -(* This function takes care of flattening successive then commands. *) - - -(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy - that t is some [PbpAtom t] *) - -(* This optimization function takes care of compacting successive Intro commands - together. *) - -let rec group_intros names = function - [] -> (match names with - [] -> [] - | l -> [PbpIntros l]) - | (PbpIntros ids)::others -> group_intros (names@ids) others - | t1::others -> - (match names with - [] -> t1::(group_intros [] others) - | l -> (PbpIntros l)::t1::(group_intros [] others)) - -let rec optim2 = function - | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2) - | PbpThen tl -> PbpThen (group_intros [] tl) - - -let rec cleanup_clears str_list = function - [] -> [] - | x::tail -> - if List.mem x str_list then cleanup_clears str_list tail - else x::(cleanup_clears str_list tail);; - -(* This function takes care of compacting instanciations of universal - quantifications. *) - -let rec optim3_aux str_list = function - (PbpGeneralize (h,l1)):: - (PbpIntros [zz,IntroIdentifier s])::(PbpGeneralize (h',l2))::others - when s=h' -> - optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others) - | (PbpTryClear names)::other -> - (match cleanup_clears str_list names with - [] -> other - | l -> (PbpTryClear l)::other) - | a::l -> a::(optim3_aux str_list l) - | [] -> [];; - -let rec optim3 str_list = function - PbpThens (tl1, tl2) -> - PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2) - | PbpThen tl -> PbpThen (optim3_aux str_list tl) - -let optim x = make_pbp_tactic (optim3 [] (optim2 x));; - -(* TODO -add_tactic "Traced_Try" traced_try_entry;; -*) - -let rec tactic_args_to_ints = function - [] -> [] - | (Integer n)::l -> n::(tactic_args_to_ints l) - | _ -> failwith "expecting only numbers";; - -(* -let pbp_tac display_function = function - (Identifier a)::l -> - (function g -> - let str = (string_of_id a) in - let (ou,tstr) = (get_hyp_by_name g str) in - let exp_ast = - pbpt default_ast - (match ou with - "hyp" ->(pf_ids_of_hyps g) - |_ -> (a::(pf_ids_of_hyps g))) - [] - false - (Some str) - (kind_of_term tstr) - (tactic_args_to_ints l) in - (display_function (optim exp_ast); - tclIDTAC g)) - | ((Integer n)::_) as l -> - (function g -> - let exp_ast = - (pbpt default_ast (pf_ids_of_hyps g) [] false - None (kind_of_term (pf_concl g)) - (tactic_args_to_ints l)) in - (display_function (optim exp_ast); - tclIDTAC g)) - | [] -> (function g -> - (display_function (default_ast None (pf_concl g) []); - tclIDTAC g)) - | _ -> failwith "expecting other arguments";; - - -*) -let pbp_tac display_function idopt nl = - match idopt with - | Some str -> - (function g -> - let (ou,tstr) = (get_hyp_by_name g str) in - let exp_ast = - pbpt default_ast - (match ou with - "hyp" ->(pf_ids_of_hyps g) - |_ -> (str::(pf_ids_of_hyps g))) - [] - false - (Some str) - (kind_of_term tstr) - nl in - (display_function (optim exp_ast); tclIDTAC g)) - | None -> - if nl <> [] then - (function g -> - let exp_ast = - (pbpt default_ast (pf_ids_of_hyps g) [] false - None (kind_of_term (pf_concl g)) nl) in - (display_function (optim exp_ast); tclIDTAC g)) - else - (function g -> - (display_function - (make_pbp_tactic (default_ast None (pf_concl g) [])); - tclIDTAC g));; - - diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli deleted file mode 100644 index 9daba184..00000000 --- a/contrib/interface/pbp.mli +++ /dev/null @@ -1,2 +0,0 @@ -val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - Names.identifier option -> int list -> Proof_type.tactic diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml deleted file mode 100644 index 2ab62763..00000000 --- a/contrib/interface/showproof.ml +++ /dev/null @@ -1,1813 +0,0 @@ -(* -#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; -open Coqast;; -*) -open Environ -open Evd -open Names -open Nameops -open Libnames -open Term -open Termops -open Util -open Proof_type -open Pfedit -open Translate -open Term -open Reductionops -open Clenv -open Typing -open Inductive -open Inductiveops -open Vernacinterp -open Declarations -open Showproof_ct -open Proof_trees -open Sign -open Pp -open Printer -open Rawterm -open Tacexpr -open Genarg -(*****************************************************************************) -(* - Arbre de preuve maison: - -*) - -(* hypotheses *) - -type nhyp = {hyp_name : identifier; - hyp_type : Term.constr; - hyp_full_type: Term.constr} -;; - -type ntactic = tactic_expr -;; - -type nproof = - Notproved - | Proof of ntactic * (ntree list) - -and ngoal= - {newhyp : nhyp list; - t_concl : Term.constr; - t_full_concl: Term.constr; - t_full_env: Environ.named_context_val} -and ntree= - {t_info:string; - t_goal:ngoal; - t_proof : nproof} -;; - - -let hyps {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = lh -;; - -let concl {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = g -;; - -let proof {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = p -;; -let g_env {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = ge -;; -let sub_ntrees t = - match (proof t) with - Notproved -> [] - | Proof (_,l) -> l -;; - -let tactic t = - match (proof t) with - Notproved -> failwith "no tactic applied" - | Proof (t,_) -> t -;; - - -(* -un arbre est clos s'il ne contient pas de sous-but non prouves, -ou bien s'il a un cousin gauche qui n'est pas clos -ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. -*) -let update_closed nt = - let found_not_closed=ref false in - let rec update {t_info=b; t_goal=g; t_proof =p} = - if !found_not_closed - then {t_info="to_prove"; t_goal=g; t_proof =p} - else - match p with - Notproved -> found_not_closed:=true; - {t_info="not_proved"; t_goal=g; t_proof =p} - | Proof(tac,lt) -> - let lt1=List.map update lt in - let b=ref "proved" in - (List.iter - (fun x -> - if x.t_info ="not_proved" then b:="not_proved") lt1; - {t_info=(!b); - t_goal=g; - t_proof=Proof(tac,lt1)}) - in update nt - ;; - - -(* - type complet avec les hypotheses. -*) - -let long_type_hyp lh t= - let t=ref t in - List.iter (fun (n,th) -> - let ni = match n with Name ni -> ni | _ -> assert false in - t:= mkProd(n,th,subst_term (mkVar ni) !t)) - (List.rev lh); - !t -;; - -(* let long_type_hyp x y = y;; *) - -(* Expansion des tactikelles *) - -let seq_to_lnhyp sign sign' cl = - let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in - let nh=List.map (fun (id,c,ty) -> - {hyp_name=id; - hyp_type=ty; - hyp_full_type= - let res= long_type_hyp !lh ty in - lh:=(!lh)@[(Name id,ty)]; - res}) - sign' - in - {newhyp=nh; - t_concl=cl; - t_full_concl=long_type_hyp !lh cl; - t_full_env = Environ.val_of_named_context (sign@sign')} -;; - - -let rule_is_complex r = - match r with - Nested (Tactic - ((TacArg (Tacexp _) - |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true - |_ -> false -;; - -let rule_to_ntactic r = - let rt = - (match r with - Nested(Tactic (t,_),_) -> t - | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h)) - | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in - if rule_is_complex r - then (match rt with - TacArg (Tacexp _) as t -> t - | _ -> assert false) - - else rt -;; - -(* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt *) - - -let fill_unproved nt l = - let lnt = ref l in - let rec fill nt = - let {t_goal=g;t_proof=p}=nt in - match p with - Notproved -> let p=List.hd (!lnt) in - lnt:=List.tl (!lnt); - {t_info="to_prove";t_goal=g;t_proof=p} - |Proof(tac,lt) -> - {t_info="to_prove";t_goal=g; - t_proof=Proof(tac,List.map fill lt)} - in fill nt -;; -(* Differences entre signatures *) - -let new_sign osign sign = - let res=ref [] in - List.iter (fun (id,c,ty) -> - try (let (_,_,_ty1)= (lookup_named id osign) in - ()) - with Not_found -> res:=(id,c,ty)::(!res)) - sign; - !res -;; - -let old_sign osign sign = - let res=ref [] in - List.iter (fun (id,c,ty) -> - try (let (_,_,ty1) = (lookup_named id osign) in - if ty1 = ty then res:=(id,c,ty)::(!res)) - with Not_found -> ()) - sign; - !res -;; - -(* convertit l'arbre de preuve courant en ntree *) -let to_nproof sigma osign pf = - let rec to_nproof_rec sigma osign pf = - let {evar_hyps=sign;evar_concl=cl} = pf.goal in - let sign = Environ.named_context_of_val sign in - let nsign = new_sign osign sign in - let oldsign = old_sign osign sign in - match pf.ref with - - None -> {t_info="to_prove"; - t_goal=(seq_to_lnhyp oldsign nsign cl); - t_proof=Notproved} - | Some(r,spfl) -> - if rule_is_complex r - then ( - let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in - let ntree= fill_unproved p1 - (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) - spfl) in - (match r with - Nested(Tactic (TacAtom (_, TacAuto _),_),_) -> - if spfl=[] - then - {t_info="to_prove"; - t_goal= {newhyp=[]; - t_concl=concl ntree; - t_full_concl=ntree.t_goal.t_full_concl; - t_full_env=ntree.t_goal.t_full_env}; - t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} - else ntree - | _ -> ntree)) - else - {t_info="to_prove"; - t_goal=(seq_to_lnhyp oldsign nsign cl); - t_proof=(Proof (rule_to_ntactic r, - List.map (fun x -> to_nproof_rec sigma sign x) spfl))} - in update_closed (to_nproof_rec sigma osign pf) - ;; - -(* - recupere l'arbre de preuve courant. -*) - -let get_nproof () = - to_nproof (Global.env()) [] - (Tacmach.proof_of_pftreestate (get_pftreestate())) -;; - - -(*****************************************************************************) -(* - Pprinter -*) - -let pr_void () = sphs "";; - -let list_rem l = match l with [] -> [] |x::l1->l1;; - -(* liste de chaines *) -let prls l = - let res = ref (sps (List.hd l)) in - List.iter (fun s -> - res:= sphv [ !res; spb; sps s]) (list_rem l); - !res -;; - -let prphrases f l = - spv (List.map (fun s -> sphv [f s; sps ","]) l) -;; - -(* indentation *) -let spi = spnb 3;; - -(* en colonne *) -let prl f l = - if l=[] then spe else spv (List.map f l);; -(*en colonne, avec indentation *) -let prli f l = - if l=[] then spe else sph [spi; spv (List.map f l)];; - -(* - Langues. -*) - -let rand l = - List.nth l (Random.int (List.length l)) -;; - -type natural_languages = French | English;; -let natural_language = ref French;; - -(*****************************************************************************) -(* - Les liens html pour proof-by-pointing -*) - -(* le path du but en cours. *) - -let path=ref[1];; - -let ftag_apply =ref (fun (n:string) t -> spt t);; - -let ftag_case =ref (fun n -> sps n);; - -let ftag_elim =ref (fun n -> sps n);; - -let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);; - -let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);; - -let ftag_uselemma =ref (fun h t -> - let intro = match !natural_language with - French -> "par" - | English -> "by" - in - spuselemma intro h t);; - -let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);; - -let tag_apply = !ftag_apply;; - -let tag_case = !ftag_case;; - -let tag_elim = !ftag_elim;; - -let tag_uselemma = !ftag_uselemma;; - -let tag_hyp = !ftag_hyp;; - -let tag_hypt = !ftag_hypt;; - -let tag_toprove = !ftag_toprove;; - -(*****************************************************************************) - -(* pluriel *) -let txtn n s = - if n=1 then s - else match s with - |"un" -> "des" - |"a" -> "" - |"an" -> "" - |"une" -> "des" - |"Soit" -> "Soient" - |"Let" -> "Let" - | s -> s^"s" -;; - -let _et () = match !natural_language with - French -> sps "et" -| English -> sps "and" -;; - -let name_count = ref 0;; -let new_name () = - name_count:=(!name_count)+1; - string_of_int !name_count -;; - -let enumerate f ln = - match ln with - [] -> [] - | [x] -> [f x] - |ln -> - let rec enum_rec f ln = - (match ln with - [x;y] -> [f x; spb; sph [_et ();spb;f y]] - |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) - | _ -> assert false) - in enum_rec f ln -;; - - -let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; - -let sp_tac tac = failwith "TODO" - -let soit_A_une_proposition nh ln t= match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "une";txtn nh "proposition"]]) -| English -> - sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]]) -;; - -let on_a ()= match !natural_language with - French -> rand ["on a "] -| English ->rand ["we have "] -;; - -let bon_a ()= match !natural_language with - French -> rand ["On a "] -| English ->rand ["We have "] -;; - -let soit_X_un_element_de_T nh ln t = match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "un";txtn nh "élément";"de"]] - @[spb; spt t]) -| English -> - sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]] - @[spb; spt t]) -;; - -let soit_F_une_fonction_de_type_T nh ln t = match !natural_language with - French -> - sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]] - @[spb; spt t]) -| English -> - sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) - @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]] - @[spb; spt t]) -;; - - -let telle_que nh = match !natural_language with - French -> [prls [" ";txtn nh "telle";"que";" "]] -| English -> [prls [" "; "such";"that";" "]] -;; - -let tel_que nh = match !natural_language with - French -> [prls [" ";txtn nh "tel";"que";" "]] -| English -> [prls [" ";"such";"that";" "]] -;; - -let supposons () = match !natural_language with - French -> "Supposons " -| English -> "Suppose " -;; - -let cas () = match !natural_language with - French -> "Cas" -| English -> "Case" -;; - -let donnons_une_proposition () = match !natural_language with - French -> sph[ (prls ["Donnons";"une";"proposition"])] -| English -> sph[ (prls ["Let us give";"a";"proposition"])] -;; - -let montrons g = match !natural_language with - French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]); - spb; spt g; sps ". "] -| English -> sph[ sps (rand ["Let us";"Now"]);spb; - sps (rand ["prove";"show"]); - spb; spt g; sps ". "] -;; - -let calculons_un_element_de g = match !natural_language with - French -> sph[ (prls ["Calculons";"un";"élément";"de"]); - spb; spt g; sps ". "] -| English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]); - spb; spt g; sps ". "] -;; - -let calculons_une_fonction_de_type g = match !natural_language with - French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]); - spb; spt g; sps ". "] -| English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]); - spb; spt g; sps ". "];; - -let en_simplifiant_on_obtient g = match !natural_language with - French -> - sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"]; - rand ["on doit";"il reste à"]; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English -> - sphv [ (prls [rand ["After simplification,"; "Simplifying,"]; - rand ["we must";"it remains to"]; - rand ["prove";"show"]]); - spb; spt g; sps ". "] ;; - -let on_obtient g = match !natural_language with - French -> sph[ (prls [rand ["on doit";"il reste à"]; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English ->sph[ (prls [rand ["we must";"it remains to"]; - rand ["prove";"show"]]); - spb; spt g; sps ". "] -;; - -let reste_a_montrer g = match !natural_language with - French -> sph[ (prls ["Reste";"à"; - rand ["prouver";"montrer";"démontrer"]]); - spb; spt g; sps ". "] -| English -> sph[ (prls ["It remains";"to"; - rand ["prove";"show"]]); - spb; spt g; sps ". "] -;; - -let discutons_avec_A type_arg = match !natural_language with - French -> sphv [sps "Discutons"; spb; sps "avec"; spb; - spt type_arg; sps ":"] -| English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; - spt type_arg; sps ":"] -;; - -let utilisons_A arg1 = match !natural_language with - French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); - spb; spt arg1; sps ":"] -| English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); - spb; spt arg1; sps ":"] -;; - -let selon_les_valeurs_de_A arg1 = match !natural_language with - French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); - spb; spt arg1; sps ":"] -| English -> sphv [ (prls ["According";"values";"of"]); - spb; spt arg1; sps ":"] -;; - -let de_A_on_a arg1 = match !natural_language with - French -> sphv [ sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb; - sps (rand ["on a:";"on déduit:";"on obtient:"])] -| English -> sphv [ sps (rand ["From";"With";"Thanks to"]); spb; - spt arg1; spb; - sps (rand ["we have:";"we deduce:";"we obtain:"])] -;; - - -let procedons_par_recurrence_sur_A arg1 = match !natural_language with - French -> sphv [ (prls ["Procédons";"par";"récurrence";"sur"]); - spb; spt arg1; sps ":"] -| English -> sphv [ (prls ["By";"induction";"on"]); - spb; spt arg1; sps ":"] -;; - - -let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A - nfun tfun narg = match !natural_language with - French -> sphv [ - sphv [ prls ["Calculons";"la";"fonction"]; - spb; sps (string_of_id nfun);spb; - prls ["de";"type"]; - spb; spt tfun;spb; - prls ["par";"récurrence";"sur";"son";"argument"]; - spb; sps (string_of_int narg); sps ":"] - ] -| English -> sphv [ - sphv [ prls ["Let us compute";"the";"function"]; - spb; sps (string_of_id nfun);spb; - prls ["of";"type"]; - spb; spt tfun;spb; - prls ["by";"induction";"on";"its";"argument"]; - spb; sps (string_of_int narg); sps ":"] - ] - -;; -let pour_montrer_G_la_valeur_recherchee_est_A g arg1 = - match !natural_language with - French -> sph [sps "Pour";spb;sps "montrer"; spt g; spb; - sps ","; spb; sps "choisissons";spb; - spt arg1;sps ". " ] -| English -> sph [sps "In order to";spb;sps "show"; spt g; spb; - sps ","; spb; sps "let us choose";spb; - spt arg1;sps ". " ] -;; - -let on_se_sert_de_A arg1 = match !natural_language with - French -> sph [sps "On se sert de";spb ;spt arg1;sps ":" ] -| English -> sph [sps "We use";spb ;spt arg1;sps ":" ] -;; - - -let d_ou_A g = match !natural_language with - French -> sph [spi; sps "d'où";spb ;spt g;sps ". " ] -| English -> sph [spi; sps "then";spb ;spt g;sps ". " ] -;; - - -let coq_le_demontre_seul () = match !natural_language with - French -> rand [prls ["Coq";"le";"démontre"; "seul."]; - sps "Fastoche."; - sps "Trop cool"] -| English -> rand [prls ["Coq";"shows";"it"; "alone."]; - sps "Fingers in the nose."] -;; - -let de_A_on_deduit_donc_B arg g = match !natural_language with - French -> sph - [ sps "De"; spb; spt arg; spb; sps "on";spb; - sps "déduit";spb; sps "donc";spb; spt g ] -| English -> sph - [ sps "From"; spb; spt arg; spb; sps "we";spb; - sps "deduce";spb; sps "then";spb; spt g ] -;; - -let _A_est_immediat_par_B g arg = match !natural_language with - French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); - spb; spt arg ] -| English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); - spb; spt arg ] -;; - -let le_resultat_est arg = match !natural_language with - French -> sph [ (prls ["le";"résultat";"est"]); - spb; spt arg ] -| English -> sph [ (prls ["the";"result";"is"]); - spb; spt arg ];; - -let on_applique_la_tactique tactic tac = match !natural_language with - French -> sphv - [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] -| English -> sphv - [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] -;; - -let de_A_il_vient_B arg g = match !natural_language with - French -> sph - [ sps "De"; spb; spt arg; spb; - sps "il";spb; sps "vient";spb; spt g; sps ". " ] -| English -> sph - [ sps "From"; spb; spt arg; spb; - sps "it";spb; sps "comes";spb; spt g; sps ". " ] -;; - -let ce_qui_est_trivial () = match !natural_language with - French -> sps "Trivial." -| English -> sps "Trivial." -;; - -let en_utilisant_l_egalite_A arg = match !natural_language with - French -> sphv [ sps "En"; spb;sps "utilisant"; spb; - sps "l'egalite"; spb; spt arg; sps "," - ] -| English -> sphv [ sps "Using"; spb; - sps "the equality"; spb; spt arg; sps "," - ] -;; - -let simplifions_H_T hyp thyp = match !natural_language with - French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:"; - spb;spt thyp;sps "."] -| English -> sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:"; - spb;spt thyp;sps "."] -;; - -let grace_a_A_il_suffit_de_montrer_LA arg lg= - match !natural_language with - French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb; - spt arg;sps ",";spb; - sps "il suffit";spb; sps "de"; spb; - sps (rand["prouver";"montrer";"démontrer"]); spb] - @[spv (enumerate (fun x->x) lg)]) -| English -> sphv ([sps (rand ["Thanks to";"With"]);spb; - spt arg;sps ",";spb; - sps "it suffices";spb; sps "to"; spb; - sps (rand["prove";"show"]); spb] - @[spv (enumerate (fun x->x) lg)]) -;; -let reste_a_montrer_LA lg= - match !natural_language with - French -> sphv ([ sps "Il reste";spb; sps "à"; spb; - sps (rand["prouver";"montrer";"démontrer"]); spb] - @[spv (enumerate (fun x->x) lg)]) -| English -> sphv ([ sps "It remains";spb; sps "to"; spb; - sps (rand["prove";"show"]); spb] - @[spv (enumerate (fun x->x) lg)]) -;; -(*****************************************************************************) -(* - Traduction des hypothèses. -*) - -type n_sort= - Nprop - | Nformula - | Ntype - | Nfunction -;; - - -let sort_of_type t ts = - let t=(strip_outer_cast t) in - if is_Prop t - then Nprop - else - match ts with - Prop(Null) -> Nformula - |_ -> (match (kind_of_term t) with - Prod(_,_,_) -> Nfunction - |_ -> Ntype) -;; - -let adrel (x,t) e = - match x with - Name(xid) -> Environ.push_rel (x,None,t) e - | Anonymous -> Environ.push_rel (x,None,t) e - -let rec nsortrec vl x = - match (kind_of_term x) with - Prod(n,t,c)-> - let vl = (adrel (n,t) vl) in nsortrec vl c - | Lambda(n,t,c) -> - let vl = (adrel (n,t) vl) in nsortrec vl c - | App(f,args) -> nsortrec vl f - | Sort(Prop(Null)) -> Prop(Null) - | Sort(c) -> c - | Ind(ind) -> - let (mib,mip) = lookup_mind_specif vl ind in - new_sort_in_family (inductive_sort_family mip) - | Construct(c) -> - nsortrec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) - -> nsortrec vl x - | Cast(x,_, t)-> nsortrec vl t - | Const c -> nsortrec vl (Typeops.type_of_constant vl c) - | _ -> nsortrec vl (type_of vl Evd.empty x) -;; -let nsort x = - nsortrec (Global.env()) (strip_outer_cast x) -;; - -let sort_of_hyp h = - (sort_of_type h.hyp_type (nsort h.hyp_full_type)) -;; - -(* grouper les hypotheses successives de meme type, ou logiques. - donne une liste de liste *) -let rec group_lhyp lh = - match lh with - [] -> [] - |[h] -> [[h]] - |h::lh -> - match group_lhyp lh with - (h1::lh1)::lh2 -> - if h.hyp_type=h1.hyp_type - || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) - then (h::(h1::lh1))::lh2 - else [h]::((h1::lh1)::lh2) - |_-> assert false -;; - -(* ln noms des hypotheses, lt leurs types *) -let natural_ghyp (sort,ln,lt) intro = - let t=List.hd lt in - let nh=List.length ln in - let _ns=List.hd ln in - match sort with - Nprop -> soit_A_une_proposition nh ln t - | Ntype -> soit_X_un_element_de_T nh ln t - | Nfunction -> soit_F_une_fonction_de_type_T nh ln t - | Nformula -> - sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) - (List.combine ln lt))) -;; - -(* Cas d'une hypothese *) -let natural_hyp h = - let ns= string_of_id h.hyp_name in - let t=h.hyp_type in - let ts= (nsort h.hyp_full_type) in - natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ()) -;; - -let rec pr_ghyp lh intro= - match lh with - [] -> [] - | [(sort,ln,t)]-> - (match sort with - Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] - | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) - | (sort,ln,t)::lh -> - let hp= - ([natural_ghyp(sort,ln,t) intro] - @(match lh with - [] -> [sps ". "] - |(sort1,ln1,t1)::lh1 -> - match sort1 with - Nformula -> - (let nh=List.length ln in - match sort with - Nprop -> telle_que nh - |Nfunction -> telle_que nh - |Ntype -> tel_que nh - |Nformula -> [sps ". "]) - | _ -> [sps ". "])) in - (sphv hp)::(pr_ghyp lh "") -;; - -(* traduction d'une liste d'hypotheses groupees. *) -let prnatural_ghyp llh intro= - if llh=[] - then spe - else - sphv (pr_ghyp (List.map - (fun lh -> - let h=(List.hd lh) in - let sh = sort_of_hyp h in - let lhname = (List.map (fun h -> - string_of_id h.hyp_name) lh) in - let lhtype = (List.map (fun h -> h.hyp_type) lh) in - (sh,lhname,lhtype)) - llh) intro) -;; - - -(*****************************************************************************) -(* - Liste des hypotheses. -*) -type type_info_subgoals_hyp= - All_subgoals_hyp - | Reduce_hyp - | No_subgoals_hyp - | Case_subgoals_hyp of string (* word for introduction *) - * Term.constr (* variable *) - * string (* constructor *) - * int (* arity *) - * int (* number of constructors *) - | Case_prop_subgoals_hyp of string (* word for introduction *) - * Term.constr (* variable *) - * int (* index of constructor *) - * int (* arity *) - * int (* number of constructors *) - | Elim_subgoals_hyp of Term.constr (* variable *) - * string (* constructor *) - * int (* arity *) - * (string list) (* rec hyp *) - * int (* number of constructors *) - | Elim_prop_subgoals_hyp of Term.constr (* variable *) - * int (* index of constructor *) - * int (* arity *) - * (string list) (* rec hyp *) - * int (* number of constructors *) -;; -let rec nrem l n = - if n<=0 then l else nrem (list_rem l) (n-1) -;; - -let rec nhd l n = - if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1)) -;; - -let par_hypothese_de_recurrence () = match !natural_language with - French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])] -| English -> sphv [(prls ["by";"induction";"hypothesis";","])] -;; - -let natural_lhyp lh hi = - match hi with - All_subgoals_hyp -> - ( match lh with - [] -> spe - |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) - | Reduce_hyp -> - (match lh with - [h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type - | _-> spe) - | No_subgoals_hyp -> spe - |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *) - let s=ref c in - for i=1 to a do - let nh=(List.nth lh (i-1)) in - s:=(!s)^" "^(string_of_id nh.hyp_name); - done; - if a>0 then s:="("^(!s)^")"; - sphv [ (if ncase>1 - then sph[ sps ("-"^(cas ()));spb] - else spe); - (* spt var;sps "="; *) sps !s; sps ":"; - (prphrases (natural_hyp) (nrem lh a))] - |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) -> - prnatural_ghyp (group_lhyp lh) sintro - |Elim_subgoals_hyp (var,c,a,lhci,ncase) -> - let nlh = List.length lh in - let nlhci = List.length lhci in - let lh0 = ref [] in - for i=1 to (nlh-nlhci) do - lh0:=(!lh0)@[List.nth lh (i-1)]; - done; - let lh=nrem lh (nlh-nlhci) in - let s=ref c in - let lh1=ref [] in - for i=1 to nlhci do - let targ=(List.nth lhci (i-1))in - let nh=(List.nth lh (i-1)) in - if targ="arg" || targ="argrec" - then - (s:=(!s)^" "^(string_of_id nh.hyp_name); - lh0:=(!lh0)@[nh]) - else lh1:=(!lh1)@[nh]; - done; - let introhyprec= - (if (!lh1)=[] then spe - else par_hypothese_de_recurrence () ) - in - if a>0 then s:="("^(!s)^")"; - spv [sphv [(if ncase>1 - then sph[ sps ("-"^(cas ()));spb] - else spe); - sps !s; sps ":"]; - prnatural_ghyp (group_lhyp !lh0) (supposons ()); - introhyprec; - prl (natural_hyp) !lh1] - |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) -> - sphv [ (if ncase>1 - then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c); - sps ":";spb] - else spe); - (prphrases (natural_hyp) lh )] - -;; - -(*****************************************************************************) -(* - Analyse des tactiques. -*) - -let name_tactic = function - | TacIntroPattern _ -> "Intro" - | TacAssumption -> "Assumption" - | _ -> failwith "TODO" -;; - -(* -let arg1_tactic tac = - match tac with - (Node(_,"Interp", - (Node(_,_, - (Node(_,_,x::_))::_))::_))::_ ->x - | (Node(_,_,x::_))::_ -> x - | x::_ -> x - | _ -> assert false -;; -*) - -let arg1_tactic tac = failwith "TODO";; - -type type_info_subgoals = - {ihsg: type_info_subgoals_hyp; - isgintro : string} -;; - -let rec show_goal lh ig g gs = - match ig with - "intros" -> - if lh = [] - then spe - else show_goal lh "standard" g gs - |"standard" -> - (match (sort_of_type g gs) with - Nprop -> donnons_une_proposition () - | Nformula -> montrons g - | Ntype -> calculons_un_element_de g - | Nfunction ->calculons_une_fonction_de_type g) - | "apply" -> show_goal lh "" g gs - | "simpl" ->en_simplifiant_on_obtient g - | "rewrite" -> on_obtient g - | "equality" -> reste_a_montrer g - | "trivial_equality" -> reste_a_montrer g - | "" -> spe - |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ] -;; - -let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s = - if ig="" && lh = [] - then spe - else sphv [ show_goal lh ig g gs; sps s] -;; - -let imaginez_une_preuve_de () = match !natural_language with - French -> "Imaginez une preuve de" -| English -> "Imagine a proof of" -;; - -let donnez_un_element_de () = match !natural_language with - French -> "Donnez un element de" -| English -> "Give an element of";; - -let intro_not_proved_goal gs = - match gs with - Prop(Null) -> imaginez_une_preuve_de () - |_ -> donnez_un_element_de () -;; - -let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= - match lh with - {hyp_name=n}::_ -> n - | _ -> assert false -;; - -let rec find_type x t= - match (kind_of_term (strip_outer_cast t)) with - Prod(y,ty,t) -> - (match y with - Name y -> - if x=(string_of_id y) then ty - else find_type x t - | _ -> find_type x t) - |_-> assert false -;; - -(*********************************************************************** -Traitement des égalités -*) -(* -let is_equality e = - match (kind_of_term e) with - AppL args -> - (match (kind_of_term args.(0)) with - Const (c,_) -> - (match (string_of_sp c) with - "Equal" -> true - | "eq" -> true - | "eqT" -> true - | "identityT" -> true - | _ -> false) - | _ -> false) - | _ -> false -;; -*) - -let is_equality e = - let e= (strip_outer_cast e) in - match (kind_of_term e) with - App (f,args) -> (Array.length args) >= 3 - | _ -> false -;; - -let terms_of_equality e = - let e= (strip_outer_cast e) in - match (kind_of_term e) with - App (f,args) -> (args.(1) , args.(2)) - | _ -> assert false -;; - -let eq_term = eq_constr;; - -let is_equality_tac = function - | TacAtom (_, - (TacExtend - (_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" - |"ERewriteParallel"|"ERewriteNormal" - |"RewriteLR"|"RewriteRL"|"Replace"),_) - | TacReduce _ - | TacSymmetry _ | TacReflexivity - | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true - | _ -> false - -let equalities_ntree ig ntree = - let rec equalities_ntree ig ntree = - if not (is_equality (concl ntree)) - then [] - else - match (proof ntree) with - Notproved -> [(ig,ntree)] - | Proof (tac,ltree) -> - if is_equality_tac tac - then (match ltree with - [] -> [(ig,ntree)] - | t::_ -> let res=(equalities_ntree ig t) in - if eq_term (concl ntree) (concl t) - then res - else (ig,ntree)::res) - else [(ig,ntree)] - in - equalities_ntree ig ntree -;; - -let remove_seq_of_terms l = - let rec remove_seq_of_terms l = match l with - a::b::l -> if (eq_term (fst a) (fst b)) - then remove_seq_of_terms (b::l) - else a::(remove_seq_of_terms (b::l)) - | _ -> l - in remove_seq_of_terms l -;; - -let list_to_eq l o= - let switch = fun h h' -> (if o then h else h') in - match l with - [a] -> spt (fst a) - | (a,h)::(b,h')::l -> - let rec list_to_eq h l = - match l with - [] -> [] - | (b,h')::l -> - (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) - :: (list_to_eq (switch h' h) l) - in sph [spt a; spb; - spv ((sph [sps "="; spb; spt b; spb; - tag_uselemma (switch h h') spe]) - ::(list_to_eq (switch h' h) l))] - | _ -> assert false -;; - -let stde = Global.env;; - -let dbize env = Constrintern.interp_constr Evd.empty env;; - -(**********************************************************************) -let rec natural_ntree ig ntree = - let {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} = ntree in - let leq = List.rev (equalities_ntree ig ntree) in - if List.length leq > 1 - then (* Several equalities to treate ... *) - ( - print_string("Several equalities to treate ...\n"); - let l1 = ref [] in - let l2 = ref [] in - List.iter - (fun (_,ntree) -> - let lemma = match (proof ntree) with - Proof (tac,ltree) -> - (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *) - (match ltree with - [] ->spe - | [_] -> spe - | _::l -> sphv[sps ": "; - prli (natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="standard"}) - l])]) - with _ -> sps "simplification" ) - | Notproved -> spe - in - let (t1,t2)= terms_of_equality (concl ntree) in - l2:=(t2,lemma)::(!l2); - l1:=(t1,lemma)::(!l1)) - leq; - l1:=remove_seq_of_terms !l1; - l2:=remove_seq_of_terms !l2; - l2:=List.rev !l2; - let ltext=ref [] in - if List.length !l1 > 1 - then (ltext:=(!ltext)@[list_to_eq !l1 true]; - if List.length !l2 > 1 then - (ltext:=(!ltext)@[_et()]; - ltext:=(!ltext)@[list_to_eq !l2 false])) - else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false]; - if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext]; - let (ig,ntree)=(List.hd leq) in - spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g (nsort gf) ""); - sph !ltext; - - natural_ntree {ihsg=All_subgoals_hyp; - isgintro= - let (t1,t2)= terms_of_equality (concl ntree) in - if eq_term t1 t2 - then "trivial_equality" - else "equality"} - ntree] - ) - else - let ntext = - let gs=nsort gf in - match p with - Notproved -> spv [ (natural_lhyp lh ig.ihsg); - sph [spi; sps (intro_not_proved_goal gs); spb; - tag_toprove g ] - ] - - | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) - | Proof (TacAtom (_,tac),ltree) -> - (let ntext = - match tac with -(* Pas besoin de l'argument éventuel de la tactique *) - TacIntroPattern _ -> natural_intros ig lh g gs ltree - | TacIntroMove _ -> natural_intros ig lh g gs ltree - | TacFix (_,n) -> natural_fix ig lh g gs n ltree - | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree - | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree - | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree - | TacRight _ -> natural_right ig lh g gs ltree - | TacLeft _ -> natural_left ig lh g gs ltree - | (* "Simpl" *)TacReduce (r,cl) -> - natural_reduce ig lh g gs ge r cl ltree - | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree - | TacAuto _ -> natural_auto ig lh g gs ltree - | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree - | TacTrivial _ -> natural_trivial ig lh g gs ltree - | TacAssumption -> natural_trivial ig lh g gs ltree - | TacClear _ -> natural_clear ig lh g gs ltree -(* Besoin de l'argument de la tactique *) - | TacSimpleInductionDestruct (true,NamedHyp id) -> - natural_induction ig lh g gs ge id ltree false - | TacExtend (_,"InductionIntro",[a]) -> - let id=(out_gen wit_ident a) in - natural_induction ig lh g gs ge id ltree true - | TacApply (_,false,[c,_],None) -> - natural_apply ig lh g gs (snd c) ltree - | TacExact c -> natural_exact ig lh g gs (snd c) ltree - | TacCut c -> natural_cut ig lh g gs (snd c) ltree - | TacExtend (_,"CutIntro",[a]) -> - let _c = out_gen wit_constr a in - natural_cutintro ig lh g gs a ltree - | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false - | TacExtend (_,"CaseIntro",[a]) -> - let c = out_gen wit_constr a in - natural_case ig lh g gs ge c ltree true - | TacElim (_,(c,_),_) -> - natural_elim ig lh g gs ge (snd c) ltree false - | TacExtend (_,"ElimIntro",[a]) -> - let c = out_gen wit_constr a in - natural_elim ig lh g gs ge c ltree true - | TacExtend (_,"Rewrite",[_;a]) -> - let (c,_) = out_gen wit_constr_with_bindings a in - natural_rewrite ig lh g gs c ltree - | TacExtend (_,"ERewriteRL",[a]) -> - let c = out_gen wit_constr a in (* TODO *) - natural_rewrite ig lh g gs c ltree - | TacExtend (_,"ERewriteLR",[a]) -> - let c = out_gen wit_constr a in (* TODO *) - natural_rewrite ig lh g gs c ltree - |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree - in - ntext (* spwithtac ntext tactic*) - ) - | Proof _ -> failwith "Don't know what to do with that" - in - if info<>"not_proved" - then spshrink info ntext - else ntext -and natural_generic ig lh g gs tactic tac ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - on_applique_la_tactique tactic tac ; - (prli(natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="standard"}) - ltree) - ] -and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree) -(* - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree ig) ltree) - ] -*) -and natural_intros ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="intros"}) - ltree) - ] -and natural_apply ig lh g gs arg ltree = - let lg = List.map concl ltree in - match lg with - [] -> - spv - [ (natural_lhyp lh ig.ihsg); - de_A_il_vient_B arg g - ] - | [sg]-> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh - {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" - then "standard" - else ""} - g gs ""); - grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; - sph [spi ; natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} (List.hd ltree)] - ] - | _ -> - let ln = List.map (fun _ -> new_name()) lg in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh - {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" - then "standard" - else ""} - g gs ""); - grace_a_A_il_suffit_de_montrer_LA arg - (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) - lg ln); - sph [spi; spv (List.map2 - (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} x]) - ltree ln)] - ] -and natural_rem_goals ltree = - let lg = List.map concl ltree in - match lg with - [] -> spe - | [sg]-> - spv - [ reste_a_montrer_LA [spt sg]; - sph [spi ; natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} (List.hd ltree)] - ] - | _ -> - let ln = List.map (fun _ -> new_name()) lg in - spv - [ reste_a_montrer_LA - (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) - lg ln); - sph [spi; spv (List.map2 - (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree - {ihsg=All_subgoals_hyp; - isgintro="apply"} x]) - ltree ln)] - ] -and natural_exact ig lh g gs arg ltree = -spv - [ - (natural_lhyp lh ig.ihsg); - (let {ihsg=pi;isgintro=ig}= ig in - (show_goal2 lh {ihsg=pi;isgintro=""} - g gs "")); - (match gs with - Prop(Null) -> _A_est_immediat_par_B g arg - |_ -> le_resultat_est arg) - - ] -and natural_cut ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - (List.rev ltree)); - de_A_on_deduit_donc_B arg g - ] -and natural_cutintro ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - sph [spi; - (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""} - (List.nth ltree 1))]; - sph [spi; - (natural_ntree - {ihsg=No_subgoals_hyp;isgintro=""} - (List.nth ltree 0))] - ] -and whd_betadeltaiota x = whd_betaiota Evd.empty x -and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) -and prod_head t = - match (kind_of_term (strip_outer_cast t)) with - Prod(_,_,c) -> prod_head c -(* |App(f,a) -> f *) - | _ -> t -and string_of_sp sp = string_of_id (basename sp) -and constr_of_mind mip i = - (string_of_id mip.mind_consnames.(i-1)) -and arity_of_constr_of_mind env indf i = - (get_constructors env indf).(i-1).cs_nargs -and gLOB ge = Global.env_of_context ge (* (Global.env()) *) - -and natural_case ig lh g gs ge arg1 ltree with_intros = - let env= (gLOB ge) in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let ti =(string_of_id mip.mind_typename) in - let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in - if ncti<>1 -(* Zéro ou Plusieurs constructeurs *) - then ( - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (match (nsort targ1) with - Prop(Null) -> - (match ti with - "or" -> discutons_avec_A type_arg - | _ -> utilisons_A arg1) - |_ -> selon_les_valeurs_de_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=if with_intros - then (arity_of_constr_of_mind env indf !ci) - else 0 in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Case_prop_subgoals_hyp (supposons (),arg1,ici,aci, - (List.length ltree)) - |_-> Case_subgoals_hyp ("",arg1,nci,aci, - (List.length ltree))); - isgintro= if with_intros then "" else "standard"} - treearg) - ]) - (nrem ltree ((List.length ltree)- ncti)))); - (sph [spi; (natural_rem_goals - (nhd ltree ((List.length ltree)- ncti)))]) - ] ) -(* Cas d'un seul constructeur *) - else ( - - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - de_A_on_a arg1; - (let treearg=List.hd ltree in - let nci=(constr_of_mind mip 1) in - let aci= - if with_intros - then (arity_of_constr_of_mind env indf 1) - else 0 in - let _ici= 1 in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Case_prop_subgoals_hyp ("",arg1,1,aci, - (List.length ltree)) - |_-> Case_subgoals_hyp ("",arg1,nci,aci, - (List.length ltree))); - isgintro=""} - treearg) - ]); - (sph [spi; (natural_rem_goals - (nhd ltree ((List.length ltree)- 1)))]) - ] - ) -(* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) - -(*****************************************************************************) -(* - Elim -*) -and prod_list_var t = - match (kind_of_term (strip_outer_cast t)) with - Prod(_,t,c) -> t::(prod_list_var c) - |_ -> [] -and hd_is_mind t ti = - try (let env = Global.env() in - let IndType (indf,targ) = find_rectype env Evd.empty t in - let _ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - (string_of_id mip.mind_typename) = ti) - with _ -> false -and mind_ind_info_hyp_constr indf c = - let env = Global.env() in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _p = mib.mind_nparams in - let a = arity_of_constr_of_mind env indf c in - let lp=ref (get_constructors env indf).(c).cs_args in - let lr=ref [] in - let ti = (string_of_id mip.mind_typename) in - for i=1 to a do - match !lp with - ((_,_,t)::lp1)-> - if hd_is_mind t ti - then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1) - else (lr:=(!lr)@["arg"];lp:=lp1) - | _ -> raise (Failure "mind_ind_info_hyp_constr") - done; - !lr -(* - mind_ind_info_hyp_constr "le" 2;; -donne ["arg"; "argrec"] -mind_ind_info_hyp_constr "le" 1;; -donne [] - mind_ind_info_hyp_constr "nat" 2;; -donne ["argrec"] -*) - -and natural_elim ig lh g gs ge arg1 ltree with_intros= - let env= (gLOB ge) in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _ti =(string_of_id mip.mind_typename) in - let _type_arg=targ1 (* List.nth targ (mis_index dmi) *) in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (match (nsort targ1) with - Prop(Null) -> utilisons_A arg1 - |_ ->procedons_par_recurrence_sur_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= - if with_intros - then mind_ind_info_hyp_constr indf !ci - else [] in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Elim_prop_subgoals_hyp (arg1,ici,aci,hci, - (List.length ltree)) - |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, - (List.length ltree))); - isgintro= ""} - treearg) - ]) - (nhd ltree ncti))); - (sph [spi; (natural_rem_goals (nrem ltree ncti))]) - ] -(* ) - with _ ->natural_generic ig lh g gs (sps "Elim") (spt arg1) ltree *) - -(*****************************************************************************) -(* - InductionIntro n -*) -and natural_induction ig lh g gs ge arg2 ltree with_intros= - let env = (gLOB (g_env (List.hd ltree))) in - let arg1= mkVar arg2 in - let targ1 = prod_head (type_of env Evd.empty arg1) in - let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let _ncti= Array.length(get_constructors env indf) in - let (ind,_) = dest_ind_family indf in - let (mib,mip) = lookup_mind_specif env ind in - let _ti =(string_of_id mip.mind_typename) in - let _type_arg= targ1(*List.nth targ (mis_index dmi)*) in - - let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *) - (* on les enleve des hypotheses des sous-buts *) - let ltree = List.map - (fun {t_info=info; - t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p} -> - {t_info=info; - t_goal={newhyp=(nrem lh (List.length lh1)); - t_concl=g;t_full_concl=gf;t_full_env=ge}; - t_proof=p}) ltree in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (natural_lhyp lh1 All_subgoals_hyp); - (match (print_string "targ1------------\n";(nsort targ1)) with - Prop(Null) -> utilisons_A arg1 - |_ -> procedons_par_recurrence_sur_A arg1); - (let ci=ref 0 in - (prli - (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind mip !ci) in - let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= - if with_intros - then mind_ind_info_hyp_constr indf !ci - else [] in - let ici= (!ci) in - sph[ (natural_ntree - {ihsg= - (match (nsort targ1) with - Prop(Null) -> - Elim_prop_subgoals_hyp (arg1,ici,aci,hci, - (List.length ltree)) - |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, - (List.length ltree))); - isgintro= "standard"} - treearg) - ]) - ltree)) - ] -(************************************************************************) -(* Points fixes *) - -and natural_fix ig lh g gs narg ltree = - let {t_info=info; - t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1; - t_full_env=ge1};t_proof=p1}=(List.hd ltree) in - match lh1 with - {hyp_name=nfun;hyp_type=tfun}::lh2 -> - let ltree=[{t_info=info; - t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1; - t_full_env=ge1}; - t_proof=p1}] in - spv - [ (natural_lhyp lh ig.ihsg); - calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_reduce ig lh g gs ge mode la ltree = - match la with - {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro="simpl"}) - ltree) - ] - | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr -> - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree - {ihsg=Reduce_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_split ig lh g gs ge la ltree = - match la with - [arg] -> - let _env= (gLOB ge) in - let arg1= (*dbize _env*) arg in - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - pour_montrer_G_la_valeur_recherchee_est_A g arg1; - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree) - ] - | [] -> - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree) - ] - | _ -> assert false -and natural_generalize ig lh g gs ge la ltree = - match la with - [(_,(_,arg)),_] -> - let _env= (gLOB ge) in - let arg1= (*dbize env*) arg in - let _type_arg=type_of (Global.env()) Evd.empty arg in -(* let type_arg=type_of_ast ge arg in*) - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - on_se_sert_de_A arg1; - (prl (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""}) - ltree) - ] - | _ -> assert false -and natural_right ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g - ] -and natural_left ig lh g gs ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g - ] -and natural_auto ig lh g gs ltree = - match ig.isgintro with - "trivial_equality" -> spe - | _ -> - if ltree=[] - then sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - coq_le_demontre_seul ()] - else spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} - ) - ltree)] -and natural_infoauto ig lh g gs ltree = - match ig.isgintro with - "trivial_equality" -> - spshrink "trivial_equality" - (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"} - (List.hd ltree)) - | _ -> sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - coq_le_demontre_seul (); - spshrink "auto" - (sph [spi; - (natural_ntree - {ihsg=All_subgoals_hyp;isgintro=""} - (List.hd ltree))])] -and natural_trivial ig lh g gs ltree = - if ltree=[] - then sphv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - ce_qui_est_trivial () ] - else spv [(natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ". "); - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree)] -and natural_rewrite ig lh g gs arg ltree = - spv - [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - en_utilisant_l_egalite_A arg; - (prli(natural_ntree - {ihsg=All_subgoals_hyp;isgintro="rewrite"}) - ltree) - ] -;; - -let natural_ntree_path ig g = - Random.init(0); - natural_ntree ig g -;; - -let show_proof lang gpath = - (match lang with - "fr" -> natural_language:=French - |"en" -> natural_language:=English - | _ -> natural_language:=English); - path:=List.rev gpath; - name_count:=0; - let ntree=(get_nproof ()) in - let {t_info=i;t_goal=g;t_proof=p} =ntree in - root_of_text_proof - (sph [(natural_ntree_path {ihsg=All_subgoals_hyp; - isgintro="standard"} - {t_info="not_proved";t_goal=g;t_proof=p}); - spr]) - ;; - -let show_nproof path = - pp (sp_print (sph [spi; show_proof "fr" path]));; - -vinterp_add "ShowNaturalProof" - (fun _ -> - (fun () ->show_nproof[];()));; - -(*********************************************************************** -debug sous cygwin: - -PATH=/usr/local/bin:/usr/bin:$PATH -COQTOP=d:/Tools/coq-7avril -CAMLLIB=/usr/local/lib/ocaml -CAMLP4LIB=/usr/local/lib/camlp4 -export CAMLLIB -export COQTOP -export CAMLP4LIB -cd d:/Tools/pcoq/src/text -d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history - - - -Lemma l1: (A, B : Prop) A \/ B -> B -> A. -Intros. -Elim H. -Auto. -Qed. - - -Drop. - -#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; -#load "xlate.cmo";; -#load "translate.cmo";; -#load "showproof_ct.cmo";; -#load "showproof.cmo";; -#load "pbp.cmo";; -#load "debug_tac.cmo";; -#load "name_to_ast.cmo";; -#load "paths.cmo";; -#load "dad.cmo";; -#load "vtp.cmo";; -#load "history.cmo";; -#load "centaur.cmo";; -Xlate.set_xlate_mut_stuff Centaur.globcv;; -Xlate.declare_in_coq();; - -#use "showproof.ml";; - -let pproof x = pP (sp_print x);; -Pp_control.set_depth_boxes 100;; -#install_printer pproof;; - -ep();; -let bidon = ref (constr_of_string "O");; - -#trace to_nproof;; -***********************************************************************) -let ep()=show_proof "fr" [];; diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli deleted file mode 100755 index 9b6787b7..00000000 --- a/contrib/interface/showproof.mli +++ /dev/null @@ -1,21 +0,0 @@ -open Environ -open Evd -open Names -open Term -open Util -open Proof_type -open Pfedit -open Term -open Reduction -open Clenv -open Typing -open Inductive -open Vernacinterp -open Declarations -open Showproof_ct -open Proof_trees -open Sign -open Pp -open Printer - -val show_proof : string -> int list -> Ascent.ct_TEXT;; diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml deleted file mode 100644 index dd7f455d..00000000 --- a/contrib/interface/showproof_ct.ml +++ /dev/null @@ -1,184 +0,0 @@ -(*****************************************************************************) -(* - Vers Ctcoq -*) - -open Metasyntax -open Printer -open Pp -open Translate -open Ascent -open Vtp -open Xlate - -let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);; - -let sps s = - ct_text s - ;; - - -let sphs s = - ct_text s - ;; - -let spe = sphs "";; -let spb = sps " ";; -let spr = sps "Retour chariot pour Show proof";; - -let spnb n = - let s = ref "" in - for i=1 to n do s:=(!s)^" "; done; sps !s -;; - - -let rec spclean l = - match l with - [] -> [] - |x::l -> if x=spe then (spclean l) else x::(spclean l) -;; - - -let spnb n = - let s = ref "" in - for i=1 to n do s:=(!s)^" "; done; sps !s -;; - -let ct_FORMULA_constr = Hashtbl.create 50;; - -let stde() = (Global.env()) - -;; - -let spt t = - let f = (translate_constr true (stde()) t) in - Hashtbl.add ct_FORMULA_constr f t; - CT_text_formula f -;; - - - -let root_of_text_proof t= - CT_text_op [ct_text "root_of_text_proof"; - t] - ;; - -let spshrink info t = - CT_text_op [ct_text "shrink"; - CT_text_op [ct_text info; - t]] -;; - -let spuselemma intro x y = - CT_text_op [ct_text "uselemma"; - ct_text intro; - x;y] -;; - -let sptoprove p t = - CT_text_op [ct_text "to_prove"; - CT_text_path p; - ct_text "goal"; - (spt t)] -;; -let sphyp p h t = - CT_text_op [ct_text "hyp"; - CT_text_path p; - ct_text h; - (spt t)] -;; -let sphypt p h t = - CT_text_op [ct_text "hyp_with_type"; - CT_text_path p; - ct_text h; - (spt t)] -;; - -let spwithtac x t = - CT_text_op [ct_text "with_tactic"; - ct_text t; - x] -;; - - -let spv l = - let l= spclean l in - CT_text_v l -;; - -let sph l = - let l= spclean l in - CT_text_h l -;; - - -let sphv l = - let l= spclean l in - CT_text_hv l -;; - -let rec prlist_with_sep f g l = - match l with - [] -> hov 0 (mt ()) - |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) -;; - -let rec sp_print x = - match x with - | CT_coerce_ID_to_TEXT (CT_ident s) - -> (match s with - | "\n" -> fnl () - | "Retour chariot pour Show proof" -> fnl () - |_ -> str s) - | CT_text_formula f -> pr_lconstr (Hashtbl.find ct_FORMULA_constr f) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident "goal"); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (str "<b>" ++ sp_print g ++ str "</b>") - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma"); - CT_coerce_ID_to_TEXT (CT_ident intro); - l;g] -> - h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident hyp); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (str hyp) - - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type"); - CT_text_path (CT_signed_int_list p); - CT_coerce_ID_to_TEXT (CT_ident hyp); - g] -> - let _p=(List.map (fun y -> match y with - (CT_coerce_INT_to_SIGNED_INT - (CT_int x)) -> x - | _ -> raise (Failure "sp_print")) p) in - h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") - - | CT_text_h l -> - h 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_v l -> - v 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_hv l -> - h 0 (prlist_with_sep (fun () -> mt ()) - (fun y -> sp_print y) l) - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink"); - CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]] -> - h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") - | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); - t]-> - sp_print t - | _ -> str "..." -;; - diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml deleted file mode 100644 index 559860b2..00000000 --- a/contrib/interface/translate.ml +++ /dev/null @@ -1,80 +0,0 @@ -open Names;; -open Sign;; -open Util;; -open Term;; -open Pp;; -open Libobject;; -open Library;; -open Vernacinterp;; -open Tacmach;; -open Pfedit;; -open Parsing;; -open Evd;; -open Evarutil;; - -open Xlate;; -open Vtp;; -open Ascent;; -open Environ;; -open Proof_type;; - -(*translates a formula into a centaur-tree --> FORMULA *) -let translate_constr at_top env c = - xlate_formula (Constrextern.extern_constr at_top env c);; - -(*translates a named_context into a centaur-tree --> PREMISES_LIST *) -(* this code is inspired from printer.ml (function pr_named_context_of) *) -let translate_sign env = - let l = - Environ.fold_named_context - (fun env (id,v,c) l -> - (match v with - None -> - CT_premise(CT_ident(string_of_id id), translate_constr false env c) - | Some v1 -> - CT_eval_result - (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), - translate_constr false env v1, - translate_constr false env c))::l) - env ~init:[] - in - CT_premises_list l;; - -(* the function rev_and_compact performs two operations: - 1- it reverses the list of integers given as argument - 2- it replaces sequences of "1" by a negative number that is - the length of the sequence. *) -let rec rev_and_compact l = function - [] -> l - | 1::tl -> - (match l with - n::tl' -> - if n < 0 then - rev_and_compact ((n - 1)::tl') tl - else - rev_and_compact ((-1)::l) tl - | [] -> rev_and_compact [-1] tl) - | a::tl -> - if a < 0 then - (match l with - n::tl' -> - if n < 0 then - rev_and_compact ((n + a)::tl') tl - else - rev_and_compact (a::l) tl - | [] -> rev_and_compact (a::l) tl) - else - rev_and_compact (a::l) tl;; - -(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *) -let translate_path l = - CT_signed_int_list - (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) - (rev_and_compact [] l));; - -(*translates a path and a goal into a centaur-tree --> RULE *) -let translate_goal (g:goal) = - CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);; - -let translate_goals (gl: goal list) = - CT_rule_list (List.map translate_goal gl);; diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli deleted file mode 100644 index 34841fc4..00000000 --- a/contrib/interface/translate.mli +++ /dev/null @@ -1,12 +0,0 @@ -open Ascent;; -open Evd;; -open Proof_type;; -open Environ;; -open Term;; - -val translate_goal : goal -> ct_RULE;; -val translate_goals : goal list -> ct_RULE_LIST;; -(* The boolean argument indicates whether names from the environment should *) -(* be avoided (same interpretation as for prterm_env and ast_of_constr) *) -val translate_constr : bool -> env -> constr -> ct_FORMULA;; -val translate_path : int list -> ct_SIGNED_INT_LIST;; diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc deleted file mode 100644 index 4d3dc558..00000000 --- a/contrib/interface/vernacrc +++ /dev/null @@ -1,12 +0,0 @@ -# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $ - -# This file is loaded initially by ./vernacparser. - -load_syntax_file 1 Notations -load_syntax_file 2 Logic -load_syntax_file 34 Omega -load_syntax_file 27 Ring -quiet_parse_string -Goal a. -&& END--OF--DATA -print_version diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml deleted file mode 100644 index 94609009..00000000 --- a/contrib/interface/vtp.ml +++ /dev/null @@ -1,1945 +0,0 @@ -open Ascent;; -open Pp;; - -(* LEM: This is actually generated automatically *) - -let fNODE s n = - (str "n\n") ++ - (str ("vernac$" ^ s)) ++ - (str "\n") ++ - (int n) ++ - (str "\n");; - -let fATOM s1 = - (str "a\n") ++ - (str ("vernac$" ^ s1)) ++ - (str "\n");; - -let f_atom_string = str;; -let f_atom_int = int;; -let rec fAST = function -| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x -| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x -| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x -| CT_astnode(x1, x2) -> - fID x1 ++ - fAST_LIST x2 ++ - fNODE "astnode" 2 -| CT_astpath(x1) -> - fID_LIST x1 ++ - fNODE "astpath" 1 -| CT_astslam(x1, x2) -> - fID_OPT x1 ++ - fAST x2 ++ - fNODE "astslam" 2 -and fAST_LIST = function -| CT_ast_list l -> - (List.fold_left (++) (mt()) (List.map fAST l)) ++ - fNODE "ast_list" (List.length l) -and fBINARY = function -| CT_binary x -> fATOM "binary" ++ - (f_atom_int x) ++ - str "\n" -and fBINDER = function -| CT_coerce_DEF_to_BINDER x -> fDEF x -| CT_binder(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "binder" 2 -| CT_binder_coercion(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "binder_coercion" 2 -and fBINDER_LIST = function -| CT_binder_list l -> - (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ - fNODE "binder_list" (List.length l) -and fBINDER_NE_LIST = function -| CT_binder_ne_list(x,l) -> - fBINDER x ++ - (List.fold_left (++) (mt()) (List.map fBINDER l)) ++ - fNODE "binder_ne_list" (1 + (List.length l)) -and fBINDING = function -| CT_binding(x1, x2) -> - fID_OR_INT x1 ++ - fFORMULA x2 ++ - fNODE "binding" 2 -and fBINDING_LIST = function -| CT_binding_list l -> - (List.fold_left (++) (mt()) (List.map fBINDING l)) ++ - fNODE "binding_list" (List.length l) -and fBOOL = function -| CT_false -> fNODE "false" 0 -| CT_true -> fNODE "true" 0 -and fCASE = function -| CT_case x -> fATOM "case" ++ - (f_atom_string x) ++ - str "\n" -and fCLAUSE = function -| CT_clause(x1, x2) -> - fHYP_LOCATION_LIST_OR_STAR x1 ++ - fSTAR_OPT x2 ++ - fNODE "clause" 2 -and fCOERCION_OPT = function -| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x -| CT_coercion_atm -> fNODE "coercion_atm" 0 -and fCOFIXTAC = function -| CT_cofixtac(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "cofixtac" 2 -and fCOFIX_REC = function -| CT_cofix_rec(x1, x2, x3, x4) -> - fID x1 ++ - fBINDER_LIST x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "cofix_rec" 4 -and fCOFIX_REC_LIST = function -| CT_cofix_rec_list(x,l) -> - fCOFIX_REC x ++ - (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++ - fNODE "cofix_rec_list" (1 + (List.length l)) -and fCOFIX_TAC_LIST = function -| CT_cofix_tac_list l -> - (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++ - fNODE "cofix_tac_list" (List.length l) -and fCOMMAND = function -| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x -| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x -| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x -| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x -| CT_abort(x1) -> - fID_OPT_OR_ALL x1 ++ - fNODE "abort" 1 -| CT_abstraction(x1, x2, x3) -> - fID x1 ++ - fFORMULA x2 ++ - fINT_LIST x3 ++ - fNODE "abstraction" 3 -| CT_add_field(x1, x2, x3, x4) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fFORMULA x3 ++ - fFORMULA_OPT x4 ++ - fNODE "add_field" 4 -| CT_add_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "add_natural_feature" 2 -| CT_addpath(x1, x2) -> - fSTRING x1 ++ - fID_OPT x2 ++ - fNODE "addpath" 2 -| CT_arguments_scope(x1, x2) -> - fID x1 ++ - fID_OPT_LIST x2 ++ - fNODE "arguments_scope" 2 -| CT_bind_scope(x1, x2) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fNODE "bind_scope" 2 -| CT_cd(x1) -> - fSTRING_OPT x1 ++ - fNODE "cd" 1 -| CT_check(x1) -> - fFORMULA x1 ++ - fNODE "check" 1 -| CT_class(x1) -> - fID x1 ++ - fNODE "class" 1 -| CT_close_scope(x1) -> - fID x1 ++ - fNODE "close_scope" 1 -| CT_coercion(x1, x2, x3, x4, x5) -> - fLOCAL_OPT x1 ++ - fIDENTITY_OPT x2 ++ - fID x3 ++ - fID x4 ++ - fID x5 ++ - fNODE "coercion" 5 -| CT_cofix_decl(x1) -> - fCOFIX_REC_LIST x1 ++ - fNODE "cofix_decl" 1 -| CT_compile_module(x1, x2, x3) -> - fVERBOSE_OPT x1 ++ - fID x2 ++ - fSTRING_OPT x3 ++ - fNODE "compile_module" 3 -| CT_declare_module(x1, x2, x3, x4) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_CHECK x3 ++ - fMODULE_EXPR x4 ++ - fNODE "declare_module" 4 -| CT_define_notation(x1, x2, x3, x4) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "define_notation" 4 -| CT_definition(x1, x2, x3, x4, x5) -> - fDEFN x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fDEF_BODY x4 ++ - fFORMULA_OPT x5 ++ - fNODE "definition" 5 -| CT_delim_scope(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "delim_scope" 2 -| CT_delpath(x1) -> - fSTRING x1 ++ - fNODE "delpath" 1 -| CT_derive_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "derive_depinversion" 4 -| CT_derive_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fINT_OPT x2 ++ - fID x3 ++ - fID x4 ++ - fNODE "derive_inversion" 4 -| CT_derive_inversion_with(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "derive_inversion_with" 4 -| CT_explain_proof(x1) -> - fINT_LIST x1 ++ - fNODE "explain_proof" 1 -| CT_explain_prooftree(x1) -> - fINT_LIST x1 ++ - fNODE "explain_prooftree" 1 -| CT_export_id(x1) -> - fID_NE_LIST x1 ++ - fNODE "export_id" 1 -| CT_extract_to_file(x1, x2) -> - fSTRING x1 ++ - fID_NE_LIST x2 ++ - fNODE "extract_to_file" 2 -| CT_extraction(x1) -> - fID_OPT x1 ++ - fNODE "extraction" 1 -| CT_fix_decl(x1) -> - fFIX_REC_LIST x1 ++ - fNODE "fix_decl" 1 -| CT_focus(x1) -> - fINT_OPT x1 ++ - fNODE "focus" 1 -| CT_go(x1) -> - fINT_OR_LOCN x1 ++ - fNODE "go" 1 -| CT_guarded -> fNODE "guarded" 0 -| CT_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1 ++ - fINT x2 ++ - fDESTRUCT_LOCATION x3 ++ - fFORMULA x4 ++ - fTACTIC_COM x5 ++ - fID_LIST x6 ++ - fNODE "hint_destruct" 6 -| CT_hint_extern(x1, x2, x3, x4) -> - fINT x1 ++ - fFORMULA_OPT x2 ++ - fTACTIC_COM x3 ++ - fID_LIST x4 ++ - fNODE "hint_extern" 4 -| CT_hintrewrite(x1, x2, x3, x4) -> - fORIENTATION x1 ++ - fFORMULA_NE_LIST x2 ++ - fID x3 ++ - fTACTIC_COM x4 ++ - fNODE "hintrewrite" 4 -| CT_hints(x1, x2, x3) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fID_LIST x3 ++ - fNODE "hints" 3 -| CT_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "hints_immediate" 2 -| CT_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "hints_resolve" 2 -| CT_hyp_search_pattern(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "hyp_search_pattern" 2 -| CT_implicits(x1, x2) -> - fID x1 ++ - fID_LIST_OPT x2 ++ - fNODE "implicits" 2 -| CT_import_id(x1) -> - fID_NE_LIST x1 ++ - fNODE "import_id" 1 -| CT_ind_scheme(x1) -> - fSCHEME_SPEC_LIST x1 ++ - fNODE "ind_scheme" 1 -| CT_infix(x1, x2, x3, x4) -> - fSTRING x1 ++ - fID x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "infix" 4 -| CT_inline(x1) -> - fID_NE_LIST x1 ++ - fNODE "inline" 1 -| CT_inspect(x1) -> - fINT x1 ++ - fNODE "inspect" 1 -| CT_kill_node(x1) -> - fINT x1 ++ - fNODE "kill_node" 1 -| CT_load(x1, x2) -> - fVERBOSE_OPT x1 ++ - fID_OR_STRING x2 ++ - fNODE "load" 2 -| CT_local_close_scope(x1) -> - fID x1 ++ - fNODE "local_close_scope" 1 -| CT_local_define_notation(x1, x2, x3, x4) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "local_define_notation" 4 -| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) -> - fID x1 ++ - fINT x2 ++ - fDESTRUCT_LOCATION x3 ++ - fFORMULA x4 ++ - fTACTIC_COM x5 ++ - fID_LIST x6 ++ - fNODE "local_hint_destruct" 6 -| CT_local_hint_extern(x1, x2, x3, x4) -> - fINT x1 ++ - fFORMULA x2 ++ - fTACTIC_COM x3 ++ - fID_LIST x4 ++ - fNODE "local_hint_extern" 4 -| CT_local_hints(x1, x2, x3) -> - fID x1 ++ - fID_NE_LIST x2 ++ - fID_LIST x3 ++ - fNODE "local_hints" 3 -| CT_local_hints_immediate(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "local_hints_immediate" 2 -| CT_local_hints_resolve(x1, x2) -> - fFORMULA_NE_LIST x1 ++ - fID_LIST x2 ++ - fNODE "local_hints_resolve" 2 -| CT_local_infix(x1, x2, x3, x4) -> - fSTRING x1 ++ - fID x2 ++ - fMODIFIER_LIST x3 ++ - fID_OPT x4 ++ - fNODE "local_infix" 4 -| CT_local_open_scope(x1) -> - fID x1 ++ - fNODE "local_open_scope" 1 -| CT_local_reserve_notation(x1, x2) -> - fSTRING x1 ++ - fMODIFIER_LIST x2 ++ - fNODE "local_reserve_notation" 2 -| CT_locate(x1) -> - fID x1 ++ - fNODE "locate" 1 -| CT_locate_file(x1) -> - fSTRING x1 ++ - fNODE "locate_file" 1 -| CT_locate_lib(x1) -> - fID x1 ++ - fNODE "locate_lib" 1 -| CT_locate_notation(x1) -> - fSTRING x1 ++ - fNODE "locate_notation" 1 -| CT_mind_decl(x1, x2) -> - fCO_IND x1 ++ - fIND_SPEC_LIST x2 ++ - fNODE "mind_decl" 2 -| CT_ml_add_path(x1) -> - fSTRING x1 ++ - fNODE "ml_add_path" 1 -| CT_ml_declare_modules(x1) -> - fSTRING_NE_LIST x1 ++ - fNODE "ml_declare_modules" 1 -| CT_ml_print_modules -> fNODE "ml_print_modules" 0 -| CT_ml_print_path -> fNODE "ml_print_path" 0 -| CT_module(x1, x2, x3, x4) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_CHECK x3 ++ - fMODULE_EXPR x4 ++ - fNODE "module" 4 -| CT_module_type_decl(x1, x2, x3) -> - fID x1 ++ - fMODULE_BINDER_LIST x2 ++ - fMODULE_TYPE_OPT x3 ++ - fNODE "module_type_decl" 3 -| CT_no_inline(x1) -> - fID_NE_LIST x1 ++ - fNODE "no_inline" 1 -| CT_omega_flag(x1, x2) -> - fOMEGA_MODE x1 ++ - fOMEGA_FEATURE x2 ++ - fNODE "omega_flag" 2 -| CT_open_scope(x1) -> - fID x1 ++ - fNODE "open_scope" 1 -| CT_print -> fNODE "print" 0 -| CT_print_about(x1) -> - fID x1 ++ - fNODE "print_about" 1 -| CT_print_all -> fNODE "print_all" 0 -| CT_print_classes -> fNODE "print_classes" 0 -| CT_print_ltac id -> - fID id ++ - fNODE "print_ltac" 1 -| CT_print_coercions -> fNODE "print_coercions" 0 -| CT_print_grammar(x1) -> - fGRAMMAR x1 ++ - fNODE "print_grammar" 1 -| CT_print_graph -> fNODE "print_graph" 0 -| CT_print_hint(x1) -> - fID_OPT x1 ++ - fNODE "print_hint" 1 -| CT_print_hintdb(x1) -> - fID_OR_STAR x1 ++ - fNODE "print_hintdb" 1 -| CT_print_rewrite_hintdb(x1) -> - fID x1 ++ - fNODE "print_rewrite_hintdb" 1 -| CT_print_id(x1) -> - fID x1 ++ - fNODE "print_id" 1 -| CT_print_implicit(x1) -> - fID x1 ++ - fNODE "print_implicit" 1 -| CT_print_loadpath -> fNODE "print_loadpath" 0 -| CT_print_module(x1) -> - fID x1 ++ - fNODE "print_module" 1 -| CT_print_module_type(x1) -> - fID x1 ++ - fNODE "print_module_type" 1 -| CT_print_modules -> fNODE "print_modules" 0 -| CT_print_natural(x1) -> - fID x1 ++ - fNODE "print_natural" 1 -| CT_print_natural_feature(x1) -> - fNATURAL_FEATURE x1 ++ - fNODE "print_natural_feature" 1 -| CT_print_opaqueid(x1) -> - fID x1 ++ - fNODE "print_opaqueid" 1 -| CT_print_path(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "print_path" 2 -| CT_print_proof(x1) -> - fID x1 ++ - fNODE "print_proof" 1 -| CT_print_scope(x1) -> - fID x1 ++ - fNODE "print_scope" 1 -| CT_print_setoids -> fNODE "print_setoids" 0 -| CT_print_scopes -> fNODE "print_scopes" 0 -| CT_print_section(x1) -> - fID x1 ++ - fNODE "print_section" 1 -| CT_print_states -> fNODE "print_states" 0 -| CT_print_tables -> fNODE "print_tables" 0 -| CT_print_universes(x1) -> - fSTRING_OPT x1 ++ - fNODE "print_universes" 1 -| CT_print_visibility(x1) -> - fID_OPT x1 ++ - fNODE "print_visibility" 1 -| CT_proof(x1) -> - fFORMULA x1 ++ - fNODE "proof" 1 -| CT_proof_no_op -> fNODE "proof_no_op" 0 -| CT_proof_with(x1) -> - fTACTIC_COM x1 ++ - fNODE "proof_with" 1 -| CT_pwd -> fNODE "pwd" 0 -| CT_quit -> fNODE "quit" 0 -| CT_read_module(x1) -> - fID x1 ++ - fNODE "read_module" 1 -| CT_rec_ml_add_path(x1) -> - fSTRING x1 ++ - fNODE "rec_ml_add_path" 1 -| CT_recaddpath(x1, x2) -> - fSTRING x1 ++ - fID_OPT x2 ++ - fNODE "recaddpath" 2 -| CT_record(x1, x2, x3, x4, x5, x6) -> - fCOERCION_OPT x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fFORMULA x4 ++ - fID_OPT x5 ++ - fRECCONSTR_LIST x6 ++ - fNODE "record" 6 -| CT_remove_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "remove_natural_feature" 2 -| CT_require(x1, x2, x3) -> - fIMPEXP x1 ++ - fSPEC_OPT x2 ++ - fID_NE_LIST_OR_STRING x3 ++ - fNODE "require" 3 -| CT_reserve(x1, x2) -> - fID_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "reserve" 2 -| CT_reserve_notation(x1, x2) -> - fSTRING x1 ++ - fMODIFIER_LIST x2 ++ - fNODE "reserve_notation" 2 -| CT_reset(x1) -> - fID x1 ++ - fNODE "reset" 1 -| CT_reset_section(x1) -> - fID x1 ++ - fNODE "reset_section" 1 -| CT_restart -> fNODE "restart" 0 -| CT_restore_state(x1) -> - fID x1 ++ - fNODE "restore_state" 1 -| CT_resume(x1) -> - fID_OPT x1 ++ - fNODE "resume" 1 -| CT_save(x1, x2) -> - fTHM_OPT x1 ++ - fID_OPT x2 ++ - fNODE "save" 2 -| CT_scomments(x1) -> - fSCOMMENT_CONTENT_LIST x1 ++ - fNODE "scomments" 1 -| CT_search(x1, x2) -> - fID x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search" 2 -| CT_search_about(x1, x2) -> - fID_OR_STRING_NE_LIST x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_about" 2 -| CT_search_pattern(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_pattern" 2 -| CT_search_rewrite(x1, x2) -> - fFORMULA x1 ++ - fIN_OR_OUT_MODULES x2 ++ - fNODE "search_rewrite" 2 -| CT_section_end(x1) -> - fID x1 ++ - fNODE "section_end" 1 -| CT_section_struct(x1, x2, x3) -> - fSECTION_BEGIN x1 ++ - fSECTION_BODY x2 ++ - fCOMMAND x3 ++ - fNODE "section_struct" 3 -| CT_set_natural(x1) -> - fID x1 ++ - fNODE "set_natural" 1 -| CT_set_natural_default -> fNODE "set_natural_default" 0 -| CT_set_option(x1) -> - fTABLE x1 ++ - fNODE "set_option" 1 -| CT_set_option_value(x1, x2) -> - fTABLE x1 ++ - fSINGLE_OPTION_VALUE x2 ++ - fNODE "set_option_value" 2 -| CT_set_option_value2(x1, x2) -> - fTABLE x1 ++ - fID_OR_STRING_NE_LIST x2 ++ - fNODE "set_option_value2" 2 -| CT_sethyp(x1) -> - fINT x1 ++ - fNODE "sethyp" 1 -| CT_setundo(x1) -> - fINT x1 ++ - fNODE "setundo" 1 -| CT_show_existentials -> fNODE "show_existentials" 0 -| CT_show_goal(x1) -> - fINT_OPT x1 ++ - fNODE "show_goal" 1 -| CT_show_implicit(x1) -> - fINT x1 ++ - fNODE "show_implicit" 1 -| CT_show_intro -> fNODE "show_intro" 0 -| CT_show_intros -> fNODE "show_intros" 0 -| CT_show_node -> fNODE "show_node" 0 -| CT_show_proof -> fNODE "show_proof" 0 -| CT_show_proofs -> fNODE "show_proofs" 0 -| CT_show_script -> fNODE "show_script" 0 -| CT_show_tree -> fNODE "show_tree" 0 -| CT_solve(x1, x2, x3) -> - fINT x1 ++ - fTACTIC_COM x2 ++ - fDOTDOT_OPT x3 ++ - fNODE "solve" 3 -| CT_strategy(CT_level_list x1) -> - List.fold_left (++) (mt()) - (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++ - fNODE "strategy" (List.length x1) -| CT_suspend -> fNODE "suspend" 0 -| CT_syntax_macro(x1, x2, x3) -> - fID x1 ++ - fFORMULA x2 ++ - fINT_OPT x3 ++ - fNODE "syntax_macro" 3 -| CT_tactic_definition(x1) -> - fTAC_DEF_NE_LIST x1 ++ - fNODE "tactic_definition" 1 -| CT_test_natural_feature(x1, x2) -> - fNATURAL_FEATURE x1 ++ - fID x2 ++ - fNODE "test_natural_feature" 2 -| CT_theorem_struct(x1, x2) -> - fTHEOREM_GOAL x1 ++ - fPROOF_SCRIPT x2 ++ - fNODE "theorem_struct" 2 -| CT_time(x1) -> - fCOMMAND x1 ++ - fNODE "time" 1 -| CT_undo(x1) -> - fINT_OPT x1 ++ - fNODE "undo" 1 -| CT_unfocus -> fNODE "unfocus" 0 -| CT_unset_option(x1) -> - fTABLE x1 ++ - fNODE "unset_option" 1 -| CT_unsethyp -> fNODE "unsethyp" 0 -| CT_unsetundo -> fNODE "unsetundo" 0 -| CT_user_vernac(x1, x2) -> - fID x1 ++ - fVARG_LIST x2 ++ - fNODE "user_vernac" 2 -| CT_variable(x1, x2) -> - fVAR x1 ++ - fBINDER_NE_LIST x2 ++ - fNODE "variable" 2 -| CT_write_module(x1, x2) -> - fID x1 ++ - fSTRING_OPT x2 ++ - fNODE "write_module" 2 -and fLEVEL = function -| CT_Opaque -> fNODE "opaque" 0 -| CT_Level n -> fINT n ++ fNODE "level" 1 -| CT_Expand -> fNODE "expand" 0 -and fCOMMAND_LIST = function -| CT_command_list(x,l) -> - fCOMMAND x ++ - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "command_list" (1 + (List.length l)) -and fCOMMENT = function -| CT_comment x -> fATOM "comment" ++ - (f_atom_string x) ++ - str "\n" -and fCOMMENT_S = function -| CT_comment_s l -> - (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++ - fNODE "comment_s" (List.length l) -and fCONSTR = function -| CT_constr(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "constr" 2 -| CT_constr_coercion(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "constr_coercion" 2 -and fCONSTR_LIST = function -| CT_constr_list l -> - (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++ - fNODE "constr_list" (List.length l) -and fCONTEXT_HYP_LIST = function -| CT_context_hyp_list l -> - (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++ - fNODE "context_hyp_list" (List.length l) -and fCONTEXT_PATTERN = function -| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x -| CT_context(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "context" 2 -and fCONTEXT_RULE = function -| CT_context_rule(x1, x2, x3) -> - fCONTEXT_HYP_LIST x1 ++ - fCONTEXT_PATTERN x2 ++ - fTACTIC_COM x3 ++ - fNODE "context_rule" 3 -| CT_def_context_rule(x1) -> - fTACTIC_COM x1 ++ - fNODE "def_context_rule" 1 -and fCONVERSION_FLAG = function -| CT_beta -> fNODE "beta" 0 -| CT_delta -> fNODE "delta" 0 -| CT_evar -> fNODE "evar" 0 -| CT_iota -> fNODE "iota" 0 -| CT_zeta -> fNODE "zeta" 0 -and fCONVERSION_FLAG_LIST = function -| CT_conversion_flag_list l -> - (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++ - fNODE "conversion_flag_list" (List.length l) -and fCONV_SET = function -| CT_unf l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "unf" (List.length l) -| CT_unfbut l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "unfbut" (List.length l) -and fCO_IND = function -| CT_co_ind x -> fATOM "co_ind" ++ - (f_atom_string x) ++ - str "\n" -and fDECL_NOTATION_OPT = function -| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x -| CT_decl_notation(x1, x2, x3) -> - fSTRING x1 ++ - fFORMULA x2 ++ - fID_OPT x3 ++ - fNODE "decl_notation" 3 -and fDEF = function -| CT_def(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "def" 2 -and fDEFN = function -| CT_defn x -> fATOM "defn" ++ - (f_atom_string x) ++ - str "\n" -and fDEFN_OR_THM = function -| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x -| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x -and fDEF_BODY = function -| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x -| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x -| CT_type_of(x1) -> - fFORMULA x1 ++ - fNODE "type_of" 1 -and fDEF_BODY_OPT = function -| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x -| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x -and fDEP = function -| CT_dep x -> fATOM "dep" ++ - (f_atom_string x) ++ - str "\n" -and fDESTRUCTING = function -| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x -| CT_destructing -> fNODE "destructing" 0 -and fDESTRUCT_LOCATION = function -| CT_conclusion_location -> fNODE "conclusion_location" 0 -| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0 -| CT_hypothesis_location -> fNODE "hypothesis_location" 0 -and fDOTDOT_OPT = function -| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x -| CT_dotdot -> fNODE "dotdot" 0 -and fEQN = function -| CT_eqn(x1, x2) -> - fMATCH_PATTERN_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "eqn" 2 -and fEQN_LIST = function -| CT_eqn_list l -> - (List.fold_left (++) (mt()) (List.map fEQN l)) ++ - fNODE "eqn_list" (List.length l) -and fEVAL_CMD = function -| CT_eval(x1, x2, x3) -> - fINT_OPT x1 ++ - fRED_COM x2 ++ - fFORMULA x3 ++ - fNODE "eval" 3 -and fFIXTAC = function -| CT_fixtac(x1, x2, x3) -> - fID x1 ++ - fINT x2 ++ - fFORMULA x3 ++ - fNODE "fixtac" 3 -and fFIX_BINDER = function -| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x -| CT_fix_binder(x1, x2, x3, x4) -> - fID x1 ++ - fINT x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "fix_binder" 4 -and fFIX_BINDER_LIST = function -| CT_fix_binder_list(x,l) -> - fFIX_BINDER x ++ - (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++ - fNODE "fix_binder_list" (1 + (List.length l)) -and fFIX_REC = function -| CT_fix_rec(x1, x2, x3, x4, x5) -> - fID x1 ++ - fBINDER_NE_LIST x2 ++ - fID_OPT x3 ++ - fFORMULA x4 ++ - fFORMULA x5 ++ - fNODE "fix_rec" 5 -and fFIX_REC_LIST = function -| CT_fix_rec_list(x,l) -> - fFIX_REC x ++ - (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++ - fNODE "fix_rec_list" (1 + (List.length l)) -and fFIX_TAC_LIST = function -| CT_fix_tac_list l -> - (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++ - fNODE "fix_tac_list" (List.length l) -and fFORMULA = function -| CT_coerce_BINARY_to_FORMULA x -> fBINARY x -| CT_coerce_ID_to_FORMULA x -> fID x -| CT_coerce_NUM_to_FORMULA x -> fNUM x -| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x -| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x -| CT_appc(x1, x2) -> - fFORMULA x1 ++ - fFORMULA_NE_LIST x2 ++ - fNODE "appc" 2 -| CT_arrowc(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "arrowc" 2 -| CT_bang(x1) -> - fFORMULA x1 ++ - fNODE "bang" 1 -| CT_cases(x1, x2, x3) -> - fMATCHED_FORMULA_NE_LIST x1 ++ - fFORMULA_OPT x2 ++ - fEQN_LIST x3 ++ - fNODE "cases" 3 -| CT_cofixc(x1, x2) -> - fID x1 ++ - fCOFIX_REC_LIST x2 ++ - fNODE "cofixc" 2 -| CT_elimc(x1, x2, x3, x4) -> - fCASE x1 ++ - fFORMULA_OPT x2 ++ - fFORMULA x3 ++ - fFORMULA_LIST x4 ++ - fNODE "elimc" 4 -| CT_existvarc -> fNODE "existvarc" 0 -| CT_fixc(x1, x2) -> - fID x1 ++ - fFIX_BINDER_LIST x2 ++ - fNODE "fixc" 2 -| CT_if(x1, x2, x3, x4) -> - fFORMULA x1 ++ - fRETURN_INFO x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "if" 4 -| CT_inductive_let(x1, x2, x3, x4) -> - fFORMULA_OPT x1 ++ - fID_OPT_NE_LIST x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "inductive_let" 4 -| CT_labelled_arg(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "labelled_arg" 2 -| CT_lambdac(x1, x2) -> - fBINDER_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "lambdac" 2 -| CT_let_tuple(x1, x2, x3, x4) -> - fID_OPT_NE_LIST x1 ++ - fRETURN_INFO x2 ++ - fFORMULA x3 ++ - fFORMULA x4 ++ - fNODE "let_tuple" 4 -| CT_letin(x1, x2) -> - fDEF x1 ++ - fFORMULA x2 ++ - fNODE "letin" 2 -| CT_notation(x1, x2) -> - fSTRING x1 ++ - fFORMULA_LIST x2 ++ - fNODE "notation" 2 -| CT_num_encapsulator(x1, x2) -> - fNUM_TYPE x1 ++ - fFORMULA x2 ++ - fNODE "num_encapsulator" 2 -| CT_prodc(x1, x2) -> - fBINDER_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "prodc" 2 -| CT_proj(x1, x2) -> - fFORMULA x1 ++ - fFORMULA_NE_LIST x2 ++ - fNODE "proj" 2 -and fFORMULA_LIST = function -| CT_formula_list l -> - (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ - fNODE "formula_list" (List.length l) -and fFORMULA_NE_LIST = function -| CT_formula_ne_list(x,l) -> - fFORMULA x ++ - (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++ - fNODE "formula_ne_list" (1 + (List.length l)) -and fFORMULA_OPT = function -| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x -| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x -and fFORMULA_OR_INT = function -| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x -| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x -and fGRAMMAR = function -| CT_grammar_none -> fNODE "grammar_none" 0 -and fHYP_LOCATION = function -| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x -| CT_intype(x1, x2) -> - fID x1 ++ - fINT_LIST x2 ++ - fNODE "intype" 2 -| CT_invalue(x1, x2) -> - fID x1 ++ - fINT_LIST x2 ++ - fNODE "invalue" 2 -and fHYP_LOCATION_LIST_OR_STAR = function -| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x -| CT_hyp_location_list l -> - (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++ - fNODE "hyp_location_list" (List.length l) -and fID = function -| CT_ident x -> fATOM "ident" ++ - (f_atom_string x) ++ - str "\n" -| CT_metac(x1) -> - fINT x1 ++ - fNODE "metac" 1 -| CT_metaid x -> fATOM "metaid" ++ - (f_atom_string x) ++ - str "\n" -and fIDENTITY_OPT = function -| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x -| CT_identity -> fNODE "identity" 0 -and fID_LIST = function -| CT_id_list l -> - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "id_list" (List.length l) -and fID_LIST_LIST = function -| CT_id_list_list l -> - (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++ - fNODE "id_list_list" (List.length l) -and fID_LIST_OPT = function -| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x -| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x -and fID_NE_LIST = function -| CT_id_ne_list(x,l) -> - fID x ++ - (List.fold_left (++) (mt()) (List.map fID l)) ++ - fNODE "id_ne_list" (1 + (List.length l)) -and fID_NE_LIST_OR_STAR = function -| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x -| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x -and fID_NE_LIST_OR_STRING = function -| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x -| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x -and fID_OPT = function -| CT_coerce_ID_to_ID_OPT x -> fID x -| CT_coerce_NONE_to_ID_OPT x -> fNONE x -and fID_OPT_LIST = function -| CT_id_opt_list l -> - (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ - fNODE "id_opt_list" (List.length l) -and fID_OPT_NE_LIST = function -| CT_id_opt_ne_list(x,l) -> - fID_OPT x ++ - (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++ - fNODE "id_opt_ne_list" (1 + (List.length l)) -and fID_OPT_OR_ALL = function -| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x -| CT_all -> fNODE "all" 0 -and fID_OR_INT = function -| CT_coerce_ID_to_ID_OR_INT x -> fID x -| CT_coerce_INT_to_ID_OR_INT x -> fINT x -and fID_OR_INT_OPT = function -| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x -| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x -| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x -and fID_OR_STAR = function -| CT_coerce_ID_to_ID_OR_STAR x -> fID x -| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x -and fID_OR_STRING = function -| CT_coerce_ID_to_ID_OR_STRING x -> fID x -| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x -and fID_OR_STRING_NE_LIST = function -| CT_id_or_string_ne_list(x,l) -> - fID_OR_STRING x ++ - (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++ - fNODE "id_or_string_ne_list" (1 + (List.length l)) -and fIMPEXP = function -| CT_coerce_NONE_to_IMPEXP x -> fNONE x -| CT_export -> fNODE "export" 0 -| CT_import -> fNODE "import" 0 -and fIND_SPEC = function -| CT_ind_spec(x1, x2, x3, x4, x5) -> - fID x1 ++ - fBINDER_LIST x2 ++ - fFORMULA x3 ++ - fCONSTR_LIST x4 ++ - fDECL_NOTATION_OPT x5 ++ - fNODE "ind_spec" 5 -and fIND_SPEC_LIST = function -| CT_ind_spec_list l -> - (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++ - fNODE "ind_spec_list" (List.length l) -and fINT = function -| CT_int x -> fATOM "int" ++ - (f_atom_int x) ++ - str "\n" -and fINTRO_PATT = function -| CT_coerce_ID_to_INTRO_PATT x -> fID x -| CT_disj_pattern(x,l) -> - fINTRO_PATT_LIST x ++ - (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++ - fNODE "disj_pattern" (1 + (List.length l)) -and fINTRO_PATT_LIST = function -| CT_intro_patt_list l -> - (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++ - fNODE "intro_patt_list" (List.length l) -and fINTRO_PATT_OPT = function -| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x -| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x -and fINT_LIST = function -| CT_int_list l -> - (List.fold_left (++) (mt()) (List.map fINT l)) ++ - fNODE "int_list" (List.length l) -and fINT_NE_LIST = function -| CT_int_ne_list(x,l) -> - fINT x ++ - (List.fold_left (++) (mt()) (List.map fINT l)) ++ - fNODE "int_ne_list" (1 + (List.length l)) -and fINT_OPT = function -| CT_coerce_INT_to_INT_OPT x -> fINT x -| CT_coerce_NONE_to_INT_OPT x -> fNONE x -and fINT_OR_LOCN = function -| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x -| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x -and fINT_OR_NEXT = function -| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x -| CT_next_level -> fNODE "next_level" 0 -and fINV_TYPE = function -| CT_inv_clear -> fNODE "inv_clear" 0 -| CT_inv_regular -> fNODE "inv_regular" 0 -| CT_inv_simple -> fNODE "inv_simple" 0 -and fIN_OR_OUT_MODULES = function -| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x -| CT_in_modules(x1) -> - fID_NE_LIST x1 ++ - fNODE "in_modules" 1 -| CT_out_modules(x1) -> - fID_NE_LIST x1 ++ - fNODE "out_modules" 1 -and fLET_CLAUSE = function -| CT_let_clause(x1, x2, x3) -> - fID x1 ++ - fTACTIC_OPT x2 ++ - fLET_VALUE x3 ++ - fNODE "let_clause" 3 -and fLET_CLAUSES = function -| CT_let_clauses(x,l) -> - fLET_CLAUSE x ++ - (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++ - fNODE "let_clauses" (1 + (List.length l)) -and fLET_VALUE = function -| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x -| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x -and fLOCAL_OPT = function -| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x -| CT_local -> fNODE "local" 0 -and fLOCN = function -| CT_locn x -> fATOM "locn" ++ - (f_atom_string x) ++ - str "\n" -and fMATCHED_FORMULA = function -| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x -| CT_formula_as(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "formula_as" 2 -| CT_formula_as_in(x1, x2, x3) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fFORMULA x3 ++ - fNODE "formula_as_in" 3 -| CT_formula_in(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "formula_in" 2 -and fMATCHED_FORMULA_NE_LIST = function -| CT_matched_formula_ne_list(x,l) -> - fMATCHED_FORMULA x ++ - (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++ - fNODE "matched_formula_ne_list" (1 + (List.length l)) -and fMATCH_PATTERN = function -| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x -| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x -| CT_pattern_app(x1, x2) -> - fMATCH_PATTERN x1 ++ - fMATCH_PATTERN_NE_LIST x2 ++ - fNODE "pattern_app" 2 -| CT_pattern_as(x1, x2) -> - fMATCH_PATTERN x1 ++ - fID_OPT x2 ++ - fNODE "pattern_as" 2 -| CT_pattern_delimitors(x1, x2) -> - fNUM_TYPE x1 ++ - fMATCH_PATTERN x2 ++ - fNODE "pattern_delimitors" 2 -| CT_pattern_notation(x1, x2) -> - fSTRING x1 ++ - fMATCH_PATTERN_LIST x2 ++ - fNODE "pattern_notation" 2 -and fMATCH_PATTERN_LIST = function -| CT_match_pattern_list l -> - (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ - fNODE "match_pattern_list" (List.length l) -and fMATCH_PATTERN_NE_LIST = function -| CT_match_pattern_ne_list(x,l) -> - fMATCH_PATTERN x ++ - (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++ - fNODE "match_pattern_ne_list" (1 + (List.length l)) -and fMATCH_TAC_RULE = function -| CT_match_tac_rule(x1, x2) -> - fCONTEXT_PATTERN x1 ++ - fLET_VALUE x2 ++ - fNODE "match_tac_rule" 2 -and fMATCH_TAC_RULES = function -| CT_match_tac_rules(x,l) -> - fMATCH_TAC_RULE x ++ - (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++ - fNODE "match_tac_rules" (1 + (List.length l)) -and fMODIFIER = function -| CT_entry_type(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "entry_type" 2 -| CT_format(x1) -> - fSTRING x1 ++ - fNODE "format" 1 -| CT_lefta -> fNODE "lefta" 0 -| CT_nona -> fNODE "nona" 0 -| CT_only_parsing -> fNODE "only_parsing" 0 -| CT_righta -> fNODE "righta" 0 -| CT_set_item_level(x1, x2) -> - fID_NE_LIST x1 ++ - fINT_OR_NEXT x2 ++ - fNODE "set_item_level" 2 -| CT_set_level(x1) -> - fINT x1 ++ - fNODE "set_level" 1 -and fMODIFIER_LIST = function -| CT_modifier_list l -> - (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++ - fNODE "modifier_list" (List.length l) -and fMODULE_BINDER = function -| CT_module_binder(x1, x2) -> - fID_NE_LIST x1 ++ - fMODULE_TYPE x2 ++ - fNODE "module_binder" 2 -and fMODULE_BINDER_LIST = function -| CT_module_binder_list l -> - (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++ - fNODE "module_binder_list" (List.length l) -and fMODULE_EXPR = function -| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x -| CT_module_app(x1, x2) -> - fMODULE_EXPR x1 ++ - fMODULE_EXPR x2 ++ - fNODE "module_app" 2 -and fMODULE_TYPE = function -| CT_coerce_ID_to_MODULE_TYPE x -> fID x -| CT_module_type_with_def(x1, x2, x3) -> - fMODULE_TYPE x1 ++ - fID_LIST x2 ++ - fFORMULA x3 ++ - fNODE "module_type_with_def" 3 -| CT_module_type_with_mod(x1, x2, x3) -> - fMODULE_TYPE x1 ++ - fID_LIST x2 ++ - fID x3 ++ - fNODE "module_type_with_mod" 3 -and fMODULE_TYPE_CHECK = function -| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x -| CT_only_check(x1) -> - fMODULE_TYPE x1 ++ - fNODE "only_check" 1 -and fMODULE_TYPE_OPT = function -| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x -| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x -and fNATURAL_FEATURE = function -| CT_contractible -> fNODE "contractible" 0 -| CT_implicit -> fNODE "implicit" 0 -| CT_nat_transparent -> fNODE "nat_transparent" 0 -and fNONE = function -| CT_none -> fNODE "none" 0 -and fNUM = function -| CT_int_encapsulator x -> fATOM "int_encapsulator" ++ - (f_atom_string x) ++ - str "\n" -and fNUM_TYPE = function -| CT_num_type x -> fATOM "num_type" ++ - (f_atom_string x) ++ - str "\n" -and fOMEGA_FEATURE = function -| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x -| CT_flag_action -> fNODE "flag_action" 0 -| CT_flag_system -> fNODE "flag_system" 0 -| CT_flag_time -> fNODE "flag_time" 0 -and fOMEGA_MODE = function -| CT_set -> fNODE "set" 0 -| CT_switch -> fNODE "switch" 0 -| CT_unset -> fNODE "unset" 0 -and fORIENTATION = function -| CT_lr -> fNODE "lr" 0 -| CT_rl -> fNODE "rl" 0 -and fPATTERN = function -| CT_pattern_occ(x1, x2) -> - fINT_LIST x1 ++ - fFORMULA x2 ++ - fNODE "pattern_occ" 2 -and fPATTERN_NE_LIST = function -| CT_pattern_ne_list(x,l) -> - fPATTERN x ++ - (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++ - fNODE "pattern_ne_list" (1 + (List.length l)) -and fPATTERN_OPT = function -| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x -| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x -and fPREMISE = function -| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x -| CT_eval_result(x1, x2, x3) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fFORMULA x3 ++ - fNODE "eval_result" 3 -| CT_premise(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "premise" 2 -and fPREMISES_LIST = function -| CT_premises_list l -> - (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++ - fNODE "premises_list" (List.length l) -and fPREMISE_PATTERN = function -| CT_premise_pattern(x1, x2) -> - fID_OPT x1 ++ - fCONTEXT_PATTERN x2 ++ - fNODE "premise_pattern" 2 -and fPROOF_SCRIPT = function -| CT_proof_script l -> - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "proof_script" (List.length l) -and fRECCONSTR = function -| CT_defrecconstr(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fFORMULA_OPT x3 ++ - fNODE "defrecconstr" 3 -| CT_defrecconstr_coercion(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fFORMULA_OPT x3 ++ - fNODE "defrecconstr_coercion" 3 -| CT_recconstr(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "recconstr" 2 -| CT_recconstr_coercion(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "recconstr_coercion" 2 -and fRECCONSTR_LIST = function -| CT_recconstr_list l -> - (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++ - fNODE "recconstr_list" (List.length l) -and fREC_TACTIC_FUN = function -| CT_rec_tactic_fun(x1, x2, x3) -> - fID x1 ++ - fID_OPT_NE_LIST x2 ++ - fTACTIC_COM x3 ++ - fNODE "rec_tactic_fun" 3 -and fREC_TACTIC_FUN_LIST = function -| CT_rec_tactic_fun_list(x,l) -> - fREC_TACTIC_FUN x ++ - (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++ - fNODE "rec_tactic_fun_list" (1 + (List.length l)) -and fRED_COM = function -| CT_cbv(x1, x2) -> - fCONVERSION_FLAG_LIST x1 ++ - fCONV_SET x2 ++ - fNODE "cbv" 2 -| CT_fold(x1) -> - fFORMULA_LIST x1 ++ - fNODE "fold" 1 -| CT_hnf -> fNODE "hnf" 0 -| CT_lazy(x1, x2) -> - fCONVERSION_FLAG_LIST x1 ++ - fCONV_SET x2 ++ - fNODE "lazy" 2 -| CT_pattern(x1) -> - fPATTERN_NE_LIST x1 ++ - fNODE "pattern" 1 -| CT_red -> fNODE "red" 0 -| CT_cbvvm -> fNODE "vm_compute" 0 -| CT_simpl(x1) -> - fPATTERN_OPT x1 ++ - fNODE "simpl" 1 -| CT_unfold(x1) -> - fUNFOLD_NE_LIST x1 ++ - fNODE "unfold" 1 -and fRETURN_INFO = function -| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x -| CT_as_and_return(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "as_and_return" 2 -| CT_return(x1) -> - fFORMULA x1 ++ - fNODE "return" 1 -and fRULE = function -| CT_rule(x1, x2) -> - fPREMISES_LIST x1 ++ - fFORMULA x2 ++ - fNODE "rule" 2 -and fRULE_LIST = function -| CT_rule_list l -> - (List.fold_left (++) (mt()) (List.map fRULE l)) ++ - fNODE "rule_list" (List.length l) -and fSCHEME_SPEC = function -| CT_scheme_spec(x1, x2, x3, x4) -> - fID x1 ++ - fDEP x2 ++ - fFORMULA x3 ++ - fSORT_TYPE x4 ++ - fNODE "scheme_spec" 4 -and fSCHEME_SPEC_LIST = function -| CT_scheme_spec_list(x,l) -> - fSCHEME_SPEC x ++ - (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++ - fNODE "scheme_spec_list" (1 + (List.length l)) -and fSCOMMENT_CONTENT = function -| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x -| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x -and fSCOMMENT_CONTENT_LIST = function -| CT_scomment_content_list l -> - (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++ - fNODE "scomment_content_list" (List.length l) -and fSECTION_BEGIN = function -| CT_section(x1) -> - fID x1 ++ - fNODE "section" 1 -and fSECTION_BODY = function -| CT_section_body l -> - (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++ - fNODE "section_body" (List.length l) -and fSIGNED_INT = function -| CT_coerce_INT_to_SIGNED_INT x -> fINT x -| CT_minus(x1) -> - fINT x1 ++ - fNODE "minus" 1 -and fSIGNED_INT_LIST = function -| CT_signed_int_list l -> - (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++ - fNODE "signed_int_list" (List.length l) -and fSINGLE_OPTION_VALUE = function -| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x -| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x -and fSORT_TYPE = function -| CT_sortc x -> fATOM "sortc" ++ - (f_atom_string x) ++ - str "\n" -and fSPEC_LIST = function -| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x -| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x -and fSPEC_OPT = function -| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x -| CT_spec -> fNODE "spec" 0 -and fSTAR = function -| CT_star -> fNODE "star" 0 -and fSTAR_OPT = function -| CT_coerce_NONE_to_STAR_OPT x -> fNONE x -| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x -and fSTRING = function -| CT_string x -> fATOM "string" ++ - (f_atom_string x) ++ - str "\n" -and fSTRING_NE_LIST = function -| CT_string_ne_list(x,l) -> - fSTRING x ++ - (List.fold_left (++) (mt()) (List.map fSTRING l)) ++ - fNODE "string_ne_list" (1 + (List.length l)) -and fSTRING_OPT = function -| CT_coerce_NONE_to_STRING_OPT x -> fNONE x -| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x -and fTABLE = function -| CT_coerce_ID_to_TABLE x -> fID x -| CT_table(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "table" 2 -and fTACTIC_ARG = function -| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x -| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x -| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x -| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x -| CT_void -> fNODE "void" 0 -and fTACTIC_ARG_LIST = function -| CT_tactic_arg_list(x,l) -> - fTACTIC_ARG x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++ - fNODE "tactic_arg_list" (1 + (List.length l)) -and fTACTIC_COM = function -| CT_abstract(x1, x2) -> - fID_OPT x1 ++ - fTACTIC_COM x2 ++ - fNODE "abstract" 2 -| CT_absurd(x1) -> - fFORMULA x1 ++ - fNODE "absurd" 1 -| CT_any_constructor(x1) -> - fTACTIC_OPT x1 ++ - fNODE "any_constructor" 1 -| CT_apply(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "apply" 2 -| CT_assert(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "assert" 2 -| CT_assumption -> fNODE "assumption" 0 -| CT_auto(x1) -> - fINT_OPT x1 ++ - fNODE "auto" 1 -| CT_auto_with(x1, x2) -> - fINT_OPT x1 ++ - fID_NE_LIST_OR_STAR x2 ++ - fNODE "auto_with" 2 -| CT_autorewrite(x1, x2) -> - fID_NE_LIST x1 ++ - fTACTIC_OPT x2 ++ - fNODE "autorewrite" 2 -| CT_autotdb(x1) -> - fINT_OPT x1 ++ - fNODE "autotdb" 1 -| CT_case_type(x1) -> - fFORMULA x1 ++ - fNODE "case_type" 1 -| CT_casetac(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "casetac" 2 -| CT_cdhyp(x1) -> - fID x1 ++ - fNODE "cdhyp" 1 -| CT_change(x1, x2) -> - fFORMULA x1 ++ - fCLAUSE x2 ++ - fNODE "change" 2 -| CT_change_local(x1, x2, x3) -> - fPATTERN x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "change_local" 3 -| CT_clear(x1) -> - fID_NE_LIST x1 ++ - fNODE "clear" 1 -| CT_clear_body(x1) -> - fID_NE_LIST x1 ++ - fNODE "clear_body" 1 -| CT_cofixtactic(x1, x2) -> - fID_OPT x1 ++ - fCOFIX_TAC_LIST x2 ++ - fNODE "cofixtactic" 2 -| CT_condrewrite_lr(x1, x2, x3, x4) -> - fTACTIC_COM x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fID_OPT x4 ++ - fNODE "condrewrite_lr" 4 -| CT_condrewrite_rl(x1, x2, x3, x4) -> - fTACTIC_COM x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fID_OPT x4 ++ - fNODE "condrewrite_rl" 4 -| CT_constructor(x1, x2) -> - fINT x1 ++ - fSPEC_LIST x2 ++ - fNODE "constructor" 2 -| CT_contradiction -> fNODE "contradiction" 0 -| CT_contradiction_thm(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "contradiction_thm" 2 -| CT_cut(x1) -> - fFORMULA x1 ++ - fNODE "cut" 1 -| CT_cutrewrite_lr(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "cutrewrite_lr" 2 -| CT_cutrewrite_rl(x1, x2) -> - fFORMULA x1 ++ - fID_OPT x2 ++ - fNODE "cutrewrite_rl" 2 -| CT_dauto(x1, x2) -> - fINT_OPT x1 ++ - fINT_OPT x2 ++ - fNODE "dauto" 2 -| CT_dconcl -> fNODE "dconcl" 0 -| CT_decompose_list(x1, x2) -> - fID_NE_LIST x1 ++ - fFORMULA x2 ++ - fNODE "decompose_list" 2 -| CT_decompose_record(x1) -> - fFORMULA x1 ++ - fNODE "decompose_record" 1 -| CT_decompose_sum(x1) -> - fFORMULA x1 ++ - fNODE "decompose_sum" 1 -| CT_depinversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID_OR_INT x2 ++ - fINTRO_PATT_OPT x3 ++ - fFORMULA_OPT x4 ++ - fNODE "depinversion" 4 -| CT_deprewrite_lr(x1) -> - fID x1 ++ - fNODE "deprewrite_lr" 1 -| CT_deprewrite_rl(x1) -> - fID x1 ++ - fNODE "deprewrite_rl" 1 -| CT_destruct(x1) -> - fID_OR_INT x1 ++ - fNODE "destruct" 1 -| CT_dhyp(x1) -> - fID x1 ++ - fNODE "dhyp" 1 -| CT_discriminate_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "discriminate_eq" 1 -| CT_do(x1, x2) -> - fID_OR_INT x1 ++ - fTACTIC_COM x2 ++ - fNODE "do" 2 -| CT_eapply(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "eapply" 2 -| CT_eauto(x1, x2) -> - fID_OR_INT_OPT x1 ++ - fID_OR_INT_OPT x2 ++ - fNODE "eauto" 2 -| CT_eauto_with(x1, x2, x3) -> - fID_OR_INT_OPT x1 ++ - fID_OR_INT_OPT x2 ++ - fID_NE_LIST_OR_STAR x3 ++ - fNODE "eauto_with" 3 -| CT_elim(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fUSING x3 ++ - fNODE "elim" 3 -| CT_elim_type(x1) -> - fFORMULA x1 ++ - fNODE "elim_type" 1 -| CT_exact(x1) -> - fFORMULA x1 ++ - fNODE "exact" 1 -| CT_exact_no_check(x1) -> - fFORMULA x1 ++ - fNODE "exact_no_check" 1 -| CT_vm_cast_no_check(x1) -> - fFORMULA x1 ++ - fNODE "vm_cast_no_check" 1 -| CT_exists(x1) -> - fSPEC_LIST x1 ++ - fNODE "exists" 1 -| CT_fail(x1, x2) -> - fID_OR_INT x1 ++ - fSTRING_OPT x2 ++ - fNODE "fail" 2 -| CT_first(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "first" (1 + (List.length l)) -| CT_firstorder(x1) -> - fTACTIC_OPT x1 ++ - fNODE "firstorder" 1 -| CT_firstorder_using(x1, x2) -> - fTACTIC_OPT x1 ++ - fID_NE_LIST x2 ++ - fNODE "firstorder_using" 2 -| CT_firstorder_with(x1, x2) -> - fTACTIC_OPT x1 ++ - fID_NE_LIST x2 ++ - fNODE "firstorder_with" 2 -| CT_fixtactic(x1, x2, x3) -> - fID_OPT x1 ++ - fINT x2 ++ - fFIX_TAC_LIST x3 ++ - fNODE "fixtactic" 3 -| CT_formula_marker(x1) -> - fFORMULA x1 ++ - fNODE "formula_marker" 1 -| CT_fresh(x1) -> - fSTRING_OPT x1 ++ - fNODE "fresh" 1 -| CT_generalize(x1) -> - fFORMULA_NE_LIST x1 ++ - fNODE "generalize" 1 -| CT_generalize_dependent(x1) -> - fFORMULA x1 ++ - fNODE "generalize_dependent" 1 -| CT_idtac(x1) -> - fSTRING_OPT x1 ++ - fNODE "idtac" 1 -| CT_induction(x1) -> - fID_OR_INT x1 ++ - fNODE "induction" 1 -| CT_info(x1) -> - fTACTIC_COM x1 ++ - fNODE "info" 1 -| CT_injection_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "injection_eq" 1 -| CT_instantiate(x1, x2, x3) -> - fINT x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "instantiate" 3 -| CT_intro(x1) -> - fID_OPT x1 ++ - fNODE "intro" 1 -| CT_intro_after(x1, x2) -> - fID_OPT x1 ++ - fID x2 ++ - fNODE "intro_after" 2 -| CT_intros(x1) -> - fINTRO_PATT_LIST x1 ++ - fNODE "intros" 1 -| CT_intros_until(x1) -> - fID_OR_INT x1 ++ - fNODE "intros_until" 1 -| CT_inversion(x1, x2, x3, x4) -> - fINV_TYPE x1 ++ - fID_OR_INT x2 ++ - fINTRO_PATT_OPT x3 ++ - fID_LIST x4 ++ - fNODE "inversion" 4 -| CT_left(x1) -> - fSPEC_LIST x1 ++ - fNODE "left" 1 -| CT_let_ltac(x1, x2) -> - fLET_CLAUSES x1 ++ - fLET_VALUE x2 ++ - fNODE "let_ltac" 2 -| CT_lettac(x1, x2, x3) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fNODE "lettac" 3 -| CT_match_context(x,l) -> - fCONTEXT_RULE x ++ - (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ - fNODE "match_context" (1 + (List.length l)) -| CT_match_context_reverse(x,l) -> - fCONTEXT_RULE x ++ - (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++ - fNODE "match_context_reverse" (1 + (List.length l)) -| CT_match_tac(x1, x2) -> - fTACTIC_COM x1 ++ - fMATCH_TAC_RULES x2 ++ - fNODE "match_tac" 2 -| CT_move_after(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "move_after" 2 -| CT_new_destruct(x1, x2, x3) -> - (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *) - fUSING x2 ++ - fINTRO_PATT_OPT x3 ++ - fNODE "new_destruct" 3 -| CT_new_induction(x1, x2, x3) -> - (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *) - fUSING x2 ++ - fINTRO_PATT_OPT x3 ++ - fNODE "new_induction" 3 -| CT_omega -> fNODE "omega" 0 -| CT_orelse(x1, x2) -> - fTACTIC_COM x1 ++ - fTACTIC_COM x2 ++ - fNODE "orelse" 2 -| CT_parallel(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "parallel" (1 + (List.length l)) -| CT_pose(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "pose" 2 -| CT_progress(x1) -> - fTACTIC_COM x1 ++ - fNODE "progress" 1 -| CT_prolog(x1, x2) -> - fFORMULA_LIST x1 ++ - fINT x2 ++ - fNODE "prolog" 2 -| CT_rec_tactic_in(x1, x2) -> - fREC_TACTIC_FUN_LIST x1 ++ - fTACTIC_COM x2 ++ - fNODE "rec_tactic_in" 2 -| CT_reduce(x1, x2) -> - fRED_COM x1 ++ - fCLAUSE x2 ++ - fNODE "reduce" 2 -| CT_refine(x1) -> - fFORMULA x1 ++ - fNODE "refine" 1 -| CT_reflexivity -> fNODE "reflexivity" 0 -| CT_rename(x1, x2) -> - fID x1 ++ - fID x2 ++ - fNODE "rename" 2 -| CT_repeat(x1) -> - fTACTIC_COM x1 ++ - fNODE "repeat" 1 -| CT_replace_with(x1, x2,x3,x4) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fCLAUSE x3 ++ - fTACTIC_OPT x4 ++ - fNODE "replace_with" 4 -| CT_rewrite_lr(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fCLAUSE x3 ++ - fNODE "rewrite_lr" 3 -| CT_rewrite_rl(x1, x2, x3) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fCLAUSE x3 ++ - fNODE "rewrite_rl" 3 -| CT_right(x1) -> - fSPEC_LIST x1 ++ - fNODE "right" 1 -| CT_ring(x1) -> - fFORMULA_LIST x1 ++ - fNODE "ring" 1 -| CT_simple_user_tac(x1, x2) -> - fID x1 ++ - fTACTIC_ARG_LIST x2 ++ - fNODE "simple_user_tac" 2 -| CT_simplify_eq(x1) -> - fID_OR_INT_OPT x1 ++ - fNODE "simplify_eq" 1 -| CT_specialize(x1, x2, x3) -> - fINT_OPT x1 ++ - fFORMULA x2 ++ - fSPEC_LIST x3 ++ - fNODE "specialize" 3 -| CT_split(x1) -> - fSPEC_LIST x1 ++ - fNODE "split" 1 -| CT_subst(x1) -> - fID_LIST x1 ++ - fNODE "subst" 1 -| CT_superauto(x1, x2, x3, x4) -> - fINT_OPT x1 ++ - fID_LIST x2 ++ - fDESTRUCTING x3 ++ - fUSINGTDB x4 ++ - fNODE "superauto" 4 -| CT_symmetry(x1) -> - fCLAUSE x1 ++ - fNODE "symmetry" 1 -| CT_tac_double(x1, x2) -> - fID_OR_INT x1 ++ - fID_OR_INT x2 ++ - fNODE "tac_double" 2 -| CT_tacsolve(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "tacsolve" (1 + (List.length l)) -| CT_tactic_fun(x1, x2) -> - fID_OPT_NE_LIST x1 ++ - fTACTIC_COM x2 ++ - fNODE "tactic_fun" 2 -| CT_then(x,l) -> - fTACTIC_COM x ++ - (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++ - fNODE "then" (1 + (List.length l)) -| CT_transitivity(x1) -> - fFORMULA x1 ++ - fNODE "transitivity" 1 -| CT_trivial -> fNODE "trivial" 0 -| CT_trivial_with(x1) -> - fID_NE_LIST_OR_STAR x1 ++ - fNODE "trivial_with" 1 -| CT_truecut(x1, x2) -> - fID_OPT x1 ++ - fFORMULA x2 ++ - fNODE "truecut" 2 -| CT_try(x1) -> - fTACTIC_COM x1 ++ - fNODE "try" 1 -| CT_use(x1) -> - fFORMULA x1 ++ - fNODE "use" 1 -| CT_use_inversion(x1, x2, x3) -> - fID_OR_INT x1 ++ - fFORMULA x2 ++ - fID_LIST x3 ++ - fNODE "use_inversion" 3 -| CT_user_tac(x1, x2) -> - fID x1 ++ - fTARG_LIST x2 ++ - fNODE "user_tac" 2 -and fTACTIC_OPT = function -| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x -| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x -and fTAC_DEF = function -| CT_tac_def(x1, x2) -> - fID x1 ++ - fTACTIC_COM x2 ++ - fNODE "tac_def" 2 -and fTAC_DEF_NE_LIST = function -| CT_tac_def_ne_list(x,l) -> - fTAC_DEF x ++ - (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++ - fNODE "tac_def_ne_list" (1 + (List.length l)) -and fTARG = function -| CT_coerce_BINDING_to_TARG x -> fBINDING x -| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x -| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x -| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x -| CT_coerce_PATTERN_to_TARG x -> fPATTERN x -| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x -| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x -| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x -| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x -| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x -| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x -| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x -| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x -and fTARG_LIST = function -| CT_targ_list l -> - (List.fold_left (++) (mt()) (List.map fTARG l)) ++ - fNODE "targ_list" (List.length l) -and fTERM_CHANGE = function -| CT_check_term(x1) -> - fFORMULA x1 ++ - fNODE "check_term" 1 -| CT_inst_term(x1, x2) -> - fID x1 ++ - fFORMULA x2 ++ - fNODE "inst_term" 2 -and fTEXT = function -| CT_coerce_ID_to_TEXT x -> fID x -| CT_text_formula(x1) -> - fFORMULA x1 ++ - fNODE "text_formula" 1 -| CT_text_h l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_h" (List.length l) -| CT_text_hv l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_hv" (List.length l) -| CT_text_op l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_op" (List.length l) -| CT_text_path(x1) -> - fSIGNED_INT_LIST x1 ++ - fNODE "text_path" 1 -| CT_text_v l -> - (List.fold_left (++) (mt()) (List.map fTEXT l)) ++ - fNODE "text_v" (List.length l) -and fTHEOREM_GOAL = function -| CT_goal(x1) -> - fFORMULA x1 ++ - fNODE "goal" 1 -| CT_theorem_goal(x1, x2, x3, x4) -> - fDEFN_OR_THM x1 ++ - fID x2 ++ - fBINDER_LIST x3 ++ - fFORMULA x4 ++ - fNODE "theorem_goal" 4 -and fTHM = function -| CT_thm x -> fATOM "thm" ++ - (f_atom_string x) ++ - str "\n" -and fTHM_OPT = function -| CT_coerce_NONE_to_THM_OPT x -> fNONE x -| CT_coerce_THM_to_THM_OPT x -> fTHM x -and fTYPED_FORMULA = function -| CT_typed_formula(x1, x2) -> - fFORMULA x1 ++ - fFORMULA x2 ++ - fNODE "typed_formula" 2 -and fUNFOLD = function -| CT_coerce_ID_to_UNFOLD x -> fID x -| CT_unfold_occ(x1, x2) -> - fID x1 ++ - fINT_NE_LIST x2 ++ - fNODE "unfold_occ" 2 -and fUNFOLD_NE_LIST = function -| CT_unfold_ne_list(x,l) -> - fUNFOLD x ++ - (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++ - fNODE "unfold_ne_list" (1 + (List.length l)) -and fUSING = function -| CT_coerce_NONE_to_USING x -> fNONE x -| CT_using(x1, x2) -> - fFORMULA x1 ++ - fSPEC_LIST x2 ++ - fNODE "using" 2 -and fUSINGTDB = function -| CT_coerce_NONE_to_USINGTDB x -> fNONE x -| CT_usingtdb -> fNODE "usingtdb" 0 -and fVAR = function -| CT_var x -> fATOM "var" ++ - (f_atom_string x) ++ - str "\n" -and fVARG = function -| CT_coerce_AST_to_VARG x -> fAST x -| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x -| CT_coerce_BINDER_to_VARG x -> fBINDER x -| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x -| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x -| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x -| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x -| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x -| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x -| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x -| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x -| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x -| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x -| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x -| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x -and fVARG_LIST = function -| CT_varg_list l -> - (List.fold_left (++) (mt()) (List.map fVARG l)) ++ - fNODE "varg_list" (List.length l) -and fVERBOSE_OPT = function -| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x -| CT_verbose -> fNODE "verbose" 0 -;; diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli deleted file mode 100644 index d7bd8db5..00000000 --- a/contrib/interface/vtp.mli +++ /dev/null @@ -1,16 +0,0 @@ -open Ascent;; -open Pp;; - -val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;; -val fCOMMAND : ct_COMMAND -> std_ppcmds;; -val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;; -val fFORMULA : ct_FORMULA -> std_ppcmds;; -val fID : ct_ID -> std_ppcmds;; -val fSTRING : ct_STRING -> std_ppcmds;; -val fINT : ct_INT -> std_ppcmds;; -val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;; -val fRULE : ct_RULE -> std_ppcmds;; -val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;; -val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;; -val fID_LIST : ct_ID_LIST -> std_ppcmds;; -val fTEXT : ct_TEXT -> std_ppcmds;; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml deleted file mode 100644 index e3cd56a0..00000000 --- a/contrib/interface/xlate.ml +++ /dev/null @@ -1,2267 +0,0 @@ -(** Translation from coq abstract syntax trees to centaur vernac - *) -open String;; -open Char;; -open Util;; -open Names;; -open Ascent;; -open Genarg;; -open Rawterm;; -open Termops;; -open Tacexpr;; -open Vernacexpr;; -open Decl_kinds;; -open Topconstr;; -open Libnames;; -open Goptions;; - - -(* // Verify whether this is dead code, as of coq version 7 *) -(* The following three sentences have been added to cope with a change -of strategy from the Coq team in the way rules construct ast's. The -problem is that now grammar rules will refer to identifiers by giving -their absolute name, using the mutconstruct when needed. Unfortunately, -when you have a mutconstruct structure, you don't have a way to guess -the corresponding identifier without an environment, and the parser -does not have an environment. We add one, only for the constructs -that are always loaded. *) -let type_table = ((Hashtbl.create 17) : - (string, ((string array) array)) Hashtbl.t);; - -Hashtbl.add type_table "Coq.Init.Logic.and" - [|[|"dummy";"conj"|]|];; - -Hashtbl.add type_table "Coq.Init.Datatypes.prod" - [|[|"dummy";"pair"|]|];; - -Hashtbl.add type_table "Coq.Init.Datatypes.nat" - [|[|"";"O"; "S"|]|];; - -Hashtbl.add type_table "Coq.ZArith.fast_integer.Z" -[|[|"";"ZERO";"POS";"NEG"|]|];; - - -Hashtbl.add type_table "Coq.ZArith.fast_integer.positive" -[|[|"";"xI";"xO";"xH"|]|];; - -(*The following two codes are added to cope with the distinction - between ocaml and caml-light syntax while using ctcaml to - manipulate the program *) -let code_plus = code (get "+" 0);; - -let code_minus = code (get "-" 0);; - -let coercion_description_holder = ref (function _ -> None : t -> int option);; - -let coercion_description t = !coercion_description_holder t;; - -let set_coercion_description f = - coercion_description_holder:=f; ();; - -let xlate_error s = print_endline ("xlate_error : "^s);failwith ("Translation error: " ^ s);; - -let ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;; - -let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;; - -let ctf_STRING_OPT = function - | None -> ctf_STRING_OPT_NONE - | Some s -> ctf_STRING_OPT_SOME (CT_string s) - -let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;; - -let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;; - -let ctv_ID_OPT_OR_ALL_NONE = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);; - -let ctv_FORMULA_OPT_NONE = - CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);; - -let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; - -let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT - ctv_FORMULA_OPT_NONE;; - -let ctf_ID_OPT_OR_ALL_SOME s = - CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);; - -let ctv_ID_OPT_OR_ALL_ALL = CT_all;; - -let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;; - -let ct_coerce_FORMULA_to_DEF_BODY x = - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY - (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);; - -let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;; - -let varc x = CT_coerce_ID_to_FORMULA x;; - -let xlate_ident id = CT_ident (string_of_id id) - -let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);; - -let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);; - -let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;; - -let nums_to_int_list l = CT_int_list(nums_to_int_list_aux l);; - -let num_or_var_to_int = function - | ArgArg x -> CT_int x - | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";; - -let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;; - -let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);; - -let nums_or_var_to_int_ne_list n l = - CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);; - -type iTARG = Targ_command of ct_FORMULA - | Targ_intropatt of ct_INTRO_PATT_LIST - | Targ_id_list of ct_ID_LIST - | Targ_spec_list of ct_SPEC_LIST - | Targ_binding_com of ct_FORMULA - | Targ_ident of ct_ID - | Targ_int of ct_INT - | Targ_binding of ct_BINDING - | Targ_pattern of ct_PATTERN - | Targ_unfold of ct_UNFOLD - | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST - | Targ_string of ct_STRING - | Targ_fixtac of ct_FIXTAC - | Targ_cofixtac of ct_COFIXTAC - | Targ_tacexp of ct_TACTIC_COM - | Targ_redexp of ct_RED_COM;; - -type iVARG = Varg_binder of ct_BINDER - | Varg_binderlist of ct_BINDER_LIST - | Varg_bindernelist of ct_BINDER_NE_LIST - | Varg_call of ct_ID * iVARG list - | Varg_constr of ct_FORMULA - | Varg_sorttype of ct_SORT_TYPE - | Varg_constrlist of ct_FORMULA list - | Varg_ident of ct_ID - | Varg_int of ct_INT - | Varg_intlist of ct_INT_LIST - | Varg_none - | Varg_string of ct_STRING - | Varg_tactic of ct_TACTIC_COM - | Varg_ast of ct_AST - | Varg_astlist of ct_AST_LIST - | Varg_tactic_arg of iTARG - | Varg_varglist of iVARG list;; - - -let coerce_iVARG_to_FORMULA = - function - | Varg_constr x -> x - | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x - | Varg_ident id -> CT_coerce_ID_to_FORMULA id - | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";; - -let coerce_iVARG_to_ID = - function Varg_ident id -> id - | _ -> xlate_error "coerce_iVARG_to_ID";; - -let coerce_VARG_to_ID = - function - | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) -> - x - | _ -> xlate_error "coerce_VARG_to_ID";; - -let xlate_ident_opt = - function - | None -> ctv_ID_OPT_NONE - | Some id -> ctf_ID_OPT_SOME (xlate_ident id) - -let xlate_id_to_id_or_int_opt s = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));; - -let xlate_int_to_id_or_int_opt n = - CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_ID_OR_INT (CT_int n));; - -let none_in_id_or_int_opt = - CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_NONE_to_ID_OPT(CT_none));; - -let xlate_int_opt = function - | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n) - | None -> CT_coerce_NONE_to_INT_OPT CT_none - -let xlate_int_or_var_opt_to_int_opt = function - | Some (ArgArg n) -> CT_coerce_INT_to_INT_OPT (CT_int n) - | Some (ArgVar _) -> xlate_error "int_or_var: TODO" - | None -> CT_coerce_NONE_to_INT_OPT CT_none - -let apply_or_by_notation f = function - | AN x -> f x - | ByNotation _ -> xlate_error "TODO: ByNotation" - -let tac_qualid_to_ct_ID ref = - CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) - -let loc_qualid_to_ct_ID ref = - CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) - -let int_of_meta n = int_of_string (string_of_id n) -let is_int_meta n = try let _ = int_of_meta n in true with _ -> false - -let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l) - -let reference_to_ct_ID = function - | Ident (_,id) -> CT_ident (Names.string_of_id id) - | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) - -let xlate_class = function - | FunClass -> CT_ident "FUNCLASS" - | SortClass -> CT_ident "SORTCLASS" - | RefClass qid -> loc_qualid_to_ct_ID qid - -let id_to_pattern_var ctid = - match ctid with - | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" - | CT_ident "_" -> - CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) - | CT_ident id_string -> - CT_coerce_ID_OPT_to_MATCH_PATTERN - (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) - | CT_metac _ -> assert false;; - -exception Not_natural;; - -let xlate_sort = - function - | RProp Term.Pos -> CT_sortc "Set" - | RProp Term.Null -> CT_sortc "Prop" - | RType None -> CT_sortc "Type" - | RType (Some u) -> xlate_error "xlate_sort";; - - -let xlate_qualid a = - let d,i = Libnames.repr_qualid a in - let l = Names.repr_dirpath d in - List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; - -(* // The next two functions should be modified to make direct reference - to a notation operator *) -let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; - -let xlate_reference = function - Ident(_,i) -> CT_ident (string_of_id i) - | Qualid(_, q) -> CT_ident (xlate_qualid q);; -let rec xlate_match_pattern = - function - | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference s) - | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_") - | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f) - | CPatCstr (_, f1 , (arg1 :: args)) -> - CT_pattern_app - (id_to_pattern_var (xlate_reference f1), - CT_match_pattern_ne_list - (xlate_match_pattern arg1, - List.map xlate_match_pattern args)) - | CPatAlias (_, pattern, id) -> - CT_pattern_as - (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) - | CPatOr (_,l) -> xlate_error "CPatOr: TODO" - | CPatDelimiters(_, key, p) -> - CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) - | CPatPrim (_,Numeral n) -> - CT_coerce_NUM_to_MATCH_PATTERN - (CT_int_encapsulator(Bigint.to_string n)) - | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, (l,[])) -> - CT_pattern_notation(CT_string s, - CT_match_pattern_list(List.map xlate_match_pattern l)) - | CPatNotation(_, s, (l,_)) -> - xlate_error "CPatNotation (recursive notation): TODO" -;; - - -let xlate_id_opt_aux = function - Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id)) - | Anonymous -> ctv_ID_OPT_NONE;; - -let xlate_id_opt (_, v) = xlate_id_opt_aux v;; - -let xlate_id_opt_ne_list = function - [] -> assert false - | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);; - - -let rec last = function - [] -> assert false - | [a] -> a - | a::tl -> last tl;; - -let rec decompose_last = function - [] -> assert false - | [a] -> [], a - | a::tl -> let rl, b = decompose_last tl in (a::rl), b;; - -let make_fix_struct (n,bl) = - let names = names_of_local_assums bl in - let nn = List.length names in - if nn = 1 || n = None then ctv_ID_OPT_NONE - else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));; - -let rec xlate_binder = function - (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) -and xlate_return_info = function -| (Some Anonymous, None) | (None, None) -> - CT_coerce_NONE_to_RETURN_INFO CT_none -| (None, Some t) -> CT_return(xlate_formula t) -| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t) -| (Some _, None) -> assert false -and xlate_formula_opt = - function - | None -> ctv_FORMULA_OPT_NONE - | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e) - -and xlate_binder_l = function - LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) - | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, - xlate_formula v)) -and - xlate_match_pattern_ne_list = function - [] -> assert false - | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, - List.map xlate_match_pattern l) -and translate_one_equation = function - (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) - | _ -> xlate_error "TODO: disjunctive multiple patterns" -and - xlate_binder_ne_list = function - [] -> assert false - | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) -and - xlate_binder_list = function - l -> CT_binder_list( List.map xlate_binder_l l) -and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function - - CRef r -> varc (xlate_reference r) - | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) - | CProdN(_,ll,b) as whole_term -> - let rec gather_binders = function - CProdN(_, ll, b) -> - ll@(gather_binders b) - | _ -> [] in - let rec fetch_ultimate_body = function - CProdN(_, _, b) -> fetch_ultimate_body b - | a -> a in - CT_prodc(xlate_binder_ne_list (gather_binders whole_term), - xlate_formula (fetch_ultimate_body b)) - | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) - | CLetIn(_, v, a, b) -> - CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) - | CAppExpl(_, (Some n, r), l) -> - let l', last = decompose_last l in - CT_proj(xlate_formula last, - CT_formula_ne_list - (CT_bang(varc (xlate_reference r)), - List.map xlate_formula l')) - | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) - | CAppExpl(_, (None, r), l) -> - CT_appc(CT_bang(varc (xlate_reference r)), - xlate_formula_ne_list l) - | CApp(_, (Some n,f), l) -> - let l', last = decompose_last l in - CT_proj(xlate_formula_expl last, - CT_formula_ne_list - (xlate_formula f, List.map xlate_formula_expl l')) - | CApp(_, (_,f), l) -> - CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) - | CRecord (_,_,_) -> xlate_error "CRecord: TODO" - | CCases (_, _, _, [], _) -> assert false - | CCases (_, _, ret_type, tm::tml, eqns)-> - CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm, - List.map xlate_matched_formula tml), - xlate_formula_opt ret_type, - CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns)) - | CLetTuple (_,a::l, ret_info, c, b) -> - CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a, - List.map xlate_id_opt_aux l), - xlate_return_info ret_info, - xlate_formula c, - xlate_formula b) - | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" - | CIf (_,c, ret_info, b1, b2) -> - CT_if - (xlate_formula c, xlate_return_info ret_info, - xlate_formula b1, xlate_formula b2) - - | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) - | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) - | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" - | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" - | CPrim (_, Numeral i) -> - CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) - | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" - | CHole _ -> CT_existvarc -(* I assume CDynamic has been inserted to make free form extension of - the language possible, but this would go agains the logic of pcoq anyway. *) - | CDynamic (_, _) -> assert false - | CDelimiters (_, key, num) -> - CT_num_encapsulator(CT_num_type key , xlate_formula num) - | CCast (_, e, CastConv (_, t)) -> - CT_coerce_TYPED_FORMULA_to_FORMULA - (CT_typed_formula(xlate_formula e, xlate_formula t)) - | CCast (_, e, CastCoerce) -> assert false - | CPatVar (_, (_,i)) when is_int_meta i -> - CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i))) - | CPatVar (_, (false, s)) -> - CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s)) - | CPatVar (_, (true, s)) -> - xlate_error "Second order variable not supported" - | CEvar _ -> xlate_error "CEvar not supported" - | CCoFix (_, (_, id), lm::lmi) -> - let strip_mutcorec ((_, fid), bl,arf, ardef) = - CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, - xlate_formula arf, xlate_formula ardef) in - CT_cofixc(xlate_ident id, - (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) - | CFix (_, (_, id), lm::lmi) -> - let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) = - let struct_arg = make_fix_struct (n, bl) in - let arf = xlate_formula arf in - let ardef = xlate_formula ardef in - match xlate_binder_list bl with - | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), - struct_arg, arf, ardef) - | _ -> xlate_error "mutual recursive" in - CT_fixc (xlate_ident id, - CT_fix_binder_list - (CT_coerce_FIX_REC_to_FIX_BINDER - (strip_mutrec lm), List.map - (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) - lmi)) - | CCoFix _ -> assert false - | CFix _ -> assert false -and xlate_matched_formula = function - (f, (Some x, Some y)) -> - CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y) - | (f, (None, Some y)) -> - CT_formula_in(xlate_formula f, xlate_formula y) - | (f, (Some x, None)) -> - CT_formula_as(xlate_formula f, xlate_id_opt_aux x) - | (f, (None, None)) -> - CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) -and xlate_formula_expl = function - (a, None) -> xlate_formula a - | (a, Some (_,ExplByPos (i, _))) -> - xlate_error "explicitation of implicit by rank not supported" - | (a, Some (_,ExplByName i)) -> - CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) -and xlate_formula_expl_ne_list = function - [] -> assert false - | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) -and xlate_formula_ne_list = function - [] -> assert false - | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; - -let (xlate_ident_or_metaid: - Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function - AI (_, x) -> xlate_ident x - | MetaId(_, x) -> CT_metaid x;; - -let nums_of_occs (b,nums) = - if b then nums - else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums - -let xlate_hyp = function - | AI (_,id) -> xlate_ident id - | MetaId _ -> xlate_error "MetaId should occur only in quotations" - -let xlate_hyp_location = - function - | (occs, AI (_,id)), InHypTypeOnly -> - CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) - | (occs, AI (_,id)), InHypValueOnly -> - CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) - | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr -> - CT_coerce_UNFOLD_to_HYP_LOCATION - (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | ((_,a::l as occs), AI (_,id)), InHyp -> - let nums = nums_of_occs occs in - let a = List.hd nums and l = List.tl nums in - CT_coerce_UNFOLD_to_HYP_LOCATION - (CT_unfold_occ (xlate_ident id, - CT_int_ne_list(num_or_var_to_int a, - nums_or_var_to_int_list_aux l))) - | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *) - | (_, MetaId _),_ -> - xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" - - - -let xlate_clause cls = - let hyps_info = - match cls.onhyps with - None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star - | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in - CT_clause - (hyps_info, - if cls.concl_occs <> no_occurrences_expr then - CT_coerce_STAR_to_STAR_OPT CT_star - else - CT_coerce_NONE_to_STAR_OPT CT_none) - -(** Tactics - *) -let strip_targ_spec_list = - function - | Targ_spec_list x -> x - | _ -> xlate_error "strip tactic: non binding-list argument";; - -let strip_targ_binding = - function - | Targ_binding x -> x - | _ -> xlate_error "strip tactic: non-binding argument";; - -let strip_targ_command = - function - | Targ_command x -> x - | Targ_binding_com x -> x - | _ -> xlate_error "strip tactic: non-command argument";; - -let strip_targ_ident = - function - | Targ_ident x -> x - | _ -> xlate_error "strip tactic: non-ident argument";; - -let strip_targ_int = - function - | Targ_int x -> x - | _ -> xlate_error "strip tactic: non-int argument";; - -let strip_targ_pattern = - function - | Targ_pattern x -> x - | _ -> xlate_error "strip tactic: non-pattern argument";; - -let strip_targ_unfold = - function - | Targ_unfold x -> x - | _ -> xlate_error "strip tactic: non-unfold argument";; - -let strip_targ_fixtac = - function - | Targ_fixtac x -> x - | _ -> xlate_error "strip tactic: non-fixtac argument";; - -let strip_targ_cofixtac = - function - | Targ_cofixtac x -> x - | _ -> xlate_error "strip tactic: non-cofixtac argument";; - -(*Need to transform formula to id for "Prolog" tactic problem *) -let make_ID_from_FORMULA = - function - | CT_coerce_ID_to_FORMULA id -> id - | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";; - -let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);; - -let xlate_quantified_hypothesis = function - | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) - | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) - -let xlate_quantified_hypothesis_opt = function - | None -> - CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE - | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n - | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; - -let xlate_id_or_int = function - ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) - | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; - -let xlate_explicit_binding (loc,h,c) = - CT_binding (xlate_quantified_hypothesis h, xlate_formula c) - -let xlate_bindings = function - | ImplicitBindings l -> - CT_coerce_FORMULA_LIST_to_SPEC_LIST - (CT_formula_list (List.map xlate_formula l)) - | ExplicitBindings l -> - CT_coerce_BINDING_LIST_to_SPEC_LIST - (CT_binding_list (List.map xlate_explicit_binding l)) - | NoBindings -> - CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list []) - -let strip_targ_spec_list = - function - | Targ_spec_list x -> x - | _ -> xlate_error "strip_tar_spec_list";; - -let strip_targ_intropatt = - function - | Targ_intropatt x -> x - | _ -> xlate_error "strip_targ_intropatt";; - -let get_flag r = - let conv_flags, red_ids = - let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in - if r.rDelta then - [CT_delta], CT_unfbut csts - else - (if r.rConst = [] - then (* probably useless: just for compatibility *) [] - else [CT_delta]), - CT_unf csts in - let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in - let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in - let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in - (* Rem: EVAR flag obsolète *) - conv_flags, red_ids - -let rec xlate_intro_pattern (loc,pat) = match pat with - | IntroOrAndPattern [] -> assert false - | IntroOrAndPattern (fp::ll) -> - CT_disj_pattern - (CT_intro_patt_list(List.map xlate_intro_pattern fp), - List.map - (fun l -> - CT_intro_patt_list(List.map xlate_intro_pattern l)) - ll) - | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) - | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) - | IntroAnonymous -> xlate_error "TODO: IntroAnonymous" - | IntroFresh _ -> xlate_error "TODO: IntroFresh" - | IntroRewrite _ -> xlate_error "TODO: IntroRewrite" - -let compute_INV_TYPE = function - FullInversionClear -> CT_inv_clear - | SimpleInversion -> CT_inv_simple - | FullInversion -> CT_inv_regular - -let is_tactic_special_case = function - "AutoRewrite" -> true - | _ -> false;; - -let xlate_context_pattern = function - | Term v -> - CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) - | Subterm (b, idopt, v) -> (* TODO: application pattern *) - CT_context(xlate_ident_opt idopt, xlate_formula v) - - -let xlate_match_context_hyps = function - | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b) - | Def (na,b,t) -> xlate_error "TODO: Let hyps" - (* CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b, xlate_context_pattern t);; *) - -let xlate_arg_to_id_opt = function - Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) - | None -> ctv_ID_OPT_NONE;; - -let xlate_largs_to_id_opt largs = - match List.map xlate_arg_to_id_opt largs with - fst::rest -> fst, rest - | _ -> assert false;; - -let xlate_int_or_constr = function - ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) - | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings" - | ElimOnIdent(_,i) -> - CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) - | ElimOnAnonHyp i -> - CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT(CT_int i));; - -let xlate_using = function - None -> CT_coerce_NONE_to_USING(CT_none) - | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; - -let xlate_one_unfold_block = function - ((true,[]),qid) -> - CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid) - | (((_,_::_) as occs), qid) -> - let l = nums_of_occs occs in - CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, - nums_or_var_to_int_ne_list (List.hd l) (List.tl l)) - | ((false,[]), qid) -> xlate_error "Unused" -;; - -let xlate_with_names = function - None -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE - | Some fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) - -let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level - -let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = - function - | TacVoid -> - CT_void - | Tacexp t -> - CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) - | Integer n -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n))) - | Reference r -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r))) - | TacDynamic _ -> - failwith "Dynamics not treated in xlate_ast" - | ConstrMayEval (ConstrTerm c) -> - CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG - (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c)) - | ConstrMayEval(ConstrEval(r,c)) -> - CT_coerce_EVAL_CMD_to_TACTIC_ARG - (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, - xlate_formula c)) - | ConstrMayEval(ConstrTypeOf(c)) -> - CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) - | MetaIdArg _ -> - xlate_error "MetaIdArg should only be used in quotations" - | t -> - CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t) - -and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = - function - (* Moved from xlate_tactic *) - | TacCall (_, r, a::l) -> - CT_simple_user_tac - (reference_to_ct_ID r, - CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l)) - | Reference (Ident (_,s)) -> ident_tac s - | ConstrMayEval(ConstrTerm a) -> - CT_formula_marker(xlate_formula a) - | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None) - | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s)) - | TacFreshId _ -> xlate_error "TODO: fresh with many args" - | t -> xlate_error "TODO LATER: result other than tactic or constr" - -and xlate_red_tactic = - function - | Red true -> xlate_error "" - | Red false -> CT_red - | CbvVm -> CT_cbvvm - | Hnf -> CT_hnf - | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE - | Simpl (Some (occs,c)) -> - let l = nums_of_occs occs in - CT_simpl - (CT_coerce_PATTERN_to_PATTERN_OPT - (CT_pattern_occ - (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c))) - | Cbv flag_list -> - let conv_flags, red_ids = get_flag flag_list in - CT_cbv (CT_conversion_flag_list conv_flags, red_ids) - | Lazy flag_list -> - let conv_flags, red_ids = get_flag flag_list in - CT_lazy (CT_conversion_flag_list conv_flags, red_ids) - | Unfold unf_list -> - let ct_unf_list = List.map xlate_one_unfold_block unf_list in - (match ct_unf_list with - | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) - | [] -> error "there should be at least one thing to unfold") - | Fold formula_list -> - CT_fold(CT_formula_list(List.map xlate_formula formula_list)) - | Pattern l -> - let pat_list = List.map (fun (occs,c) -> - CT_pattern_occ - (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)), - xlate_formula c)) l in - (match pat_list with - | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) - | [] -> error "Expecting at least one pattern in a Pattern command") - | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" - -and xlate_local_rec_tac = function - (* TODO LATER: local recursive tactics and global ones should be handled in - the same manner *) - | ((_,x),Tacexp (TacFun (argl,tac))) -> - let fst, rest = xlate_largs_to_id_opt argl in - CT_rec_tactic_fun(xlate_ident x, - CT_id_opt_ne_list(fst, rest), - xlate_tactic tac) - | _ -> xlate_error "TODO: more general argument of 'let rec in'" - -and xlate_tactic = - function - | TacFun (largs, t) -> - let fst, rest = xlate_largs_to_id_opt largs in - CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) - | TacThen (t1,[||],t2,[||]) -> - (match xlate_tactic t1 with - CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) - | t -> CT_then (t,[xlate_tactic t2])) - | TacThen _ -> xlate_error "TacThen generalization TODO" - | TacThens(t1,[]) -> assert false - | TacThens(t1,t::l) -> - let ct = xlate_tactic t in - let cl = List.map xlate_tactic l in - (match xlate_tactic t1 with - CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)]) - | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)])) - | TacFirst([]) -> assert false - | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l) - | TacSolve([]) -> assert false - | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l) - | TacComplete _ -> xlate_error "TODO: tactical complete" - | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) - | TacTry t -> CT_try (xlate_tactic t) - | TacRepeat t -> CT_repeat(xlate_tactic t) - | TacAbstract(t,id_opt) -> - CT_abstract((match id_opt with - None -> ctv_ID_OPT_NONE - | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), - xlate_tactic t) - | TacProgress t -> CT_progress(xlate_tactic t) - | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2) - | TacMatch (true,_,_) -> failwith "TODO: lazy match" - | TacMatch (false, exp, rules) -> - CT_match_tac(xlate_tactic exp, - match List.map - (function - | Pat ([],p,tac) -> - CT_match_tac_rule(xlate_context_pattern p, - mk_let_value tac) - | Pat (_,p,tac) -> xlate_error"No hyps in pure Match" - | All tac -> - CT_match_tac_rule - (CT_coerce_FORMULA_to_CONTEXT_PATTERN - CT_existvarc, - mk_let_value tac)) rules with - | [] -> assert false - | fst::others -> - CT_match_tac_rules(fst, others)) - | TacMatchGoal (_,_,[]) | TacMatchGoal (true,_,_) -> failwith "" - | TacMatchGoal (false,false,rule1::rules) -> - CT_match_context(xlate_context_rule rule1, - List.map xlate_context_rule rules) - | TacMatchGoal (false,true,rule1::rules) -> - CT_match_context_reverse(xlate_context_rule rule1, - List.map xlate_context_rule rules) - | TacLetIn (false, l, t) -> - let cvt_clause = - function - ((_,s),ConstrMayEval v) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_DEF_BODY_to_LET_VALUE - (formula_to_def_body v)) - | ((_,s),Tacexp t) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_tactic t)) - | ((_,s),t) -> - CT_let_clause(xlate_ident s, - CT_coerce_NONE_to_TACTIC_OPT CT_none, - CT_coerce_TACTIC_COM_to_LET_VALUE - (xlate_call_or_tacarg t)) in - let cl_l = List.map cvt_clause l in - (match cl_l with - | [] -> assert false - | fst::others -> - CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) - | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition" - | TacLetIn(true, f1::l, t) -> - let tl = CT_rec_tactic_fun_list - (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in - CT_rec_tactic_in(tl, xlate_tactic t) - | TacAtom (_, t) -> xlate_tac t - | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) - | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count, - ctf_STRING_OPT_SOME (CT_string s)) - | TacFail (count, _) -> xlate_error "TODO: generic fail message" - | TacId [] -> CT_idtac ctf_STRING_OPT_NONE - | TacId [MsgString s] -> CT_idtac(ctf_STRING_OPT_SOME (CT_string s)) - | TacId _ -> xlate_error "TODO: generic idtac message" - | TacInfo t -> CT_info(xlate_tactic t) - | TacArg a -> xlate_call_or_tacarg a - -and xlate_tac = - function - | TacExtend (_, "firstorder", tac_opt::l) -> - let t1 = - match - out_gen (wit_opt rawwit_main_tactic) tac_opt - with - | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in - (match l with - [] -> CT_firstorder t1 - | [l1] -> - (match genarg_tag l1 with - List1ArgType PreIdentArgType -> - let l2 = List.map - (fun x -> CT_ident x) - (out_gen (wit_list1 rawwit_pre_ident) l1) in - let fst,l3 = - match l2 with fst::l3 -> fst,l3 | [] -> assert false in - CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) - | List1ArgType RefArgType -> - let l2 = List.map reference_to_ct_ID - (out_gen (wit_list1 rawwit_ref) l1) in - let fst,l3 = - match l2 with fst::l3 -> fst, l3 | [] -> assert false in - CT_firstorder_with(t1, CT_id_ne_list(fst, l3)) - | _ -> assert false) - | _ -> assert false) - | TacExtend (_, "refine", [c]) -> - CT_refine (xlate_formula (snd (out_gen rawwit_casted_open_constr c))) - | TacExtend (_,"absurd",[c]) -> - CT_absurd (xlate_formula (out_gen rawwit_constr c)) - | TacExtend (_,"contradiction",[opt_c]) -> - (match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with - None -> CT_contradiction - | Some(c, b) -> - let c1 = xlate_formula c in - let bindings = xlate_bindings b in - CT_contradiction_thm(c1, bindings)) - | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) - | TacChange (Some(l,c), f, b) -> - (* TODO LATER: combine with other constructions of pattern_occ *) - let l = nums_of_occs l in - CT_change_local( - CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), - xlate_formula c), - xlate_formula f, - xlate_clause b) - | TacExtend (_,"contradiction",[]) -> CT_contradiction - | TacDoubleInduction (n1, n2) -> - CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2) - | TacExtend (_,"discriminate", []) -> - CT_discriminate_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE) - | TacExtend (_,"discriminate", [id]) -> - CT_discriminate_eq - (xlate_quantified_hypothesis_opt - (Some (out_gen rawwit_quant_hyp id))) - | TacExtend (_,"simplify_eq", []) -> - CT_simplify_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT - (CT_coerce_NONE_to_ID_OPT CT_none)) - | TacExtend (_,"simplify_eq", [id]) -> - let id1 = out_gen rawwit_quant_hyp id in - let id2 = CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT - (xlate_quantified_hypothesis id1) in - CT_simplify_eq id2 - | TacExtend (_,"injection", []) -> - CT_injection_eq (CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE) - | TacExtend (_,"injection", [id]) -> - CT_injection_eq - (xlate_quantified_hypothesis_opt - (Some (out_gen rawwit_quant_hyp id))) - | TacExtend (_,"injection_as", [idopt;ipat]) -> - xlate_error "TODO: injection as" - | TacFix (idopt, n) -> - CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) - | TacMutualFix (false, id, n, fixtac_list) -> - let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in - CT_fixtactic - (ctf_ID_OPT_SOME (xlate_ident id), CT_int n, - CT_fix_tac_list (List.map f fixtac_list)) - | TacMutualFix (true, id, n, fixtac_list) -> - xlate_error "TODO: non user-visible fix" - | TacCofix idopt -> - CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list []) - | TacMutualCofix (false, id, cofixtac_list) -> - let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in - CT_cofixtactic - (CT_coerce_ID_to_ID_OPT (xlate_ident id), - CT_cofix_tac_list (List.map f cofixtac_list)) - | TacMutualCofix (true, id, cofixtac_list) -> - xlate_error "TODO: non user-visible cofix" - | TacIntrosUntil (NamedHyp id) -> - CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) - | TacIntrosUntil (AnonHyp n) -> - CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) - | TacIntroMove (Some id1, MoveAfter id2) -> - CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2) - | TacIntroMove (None, MoveAfter id2) -> - CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_hyp id2) - | TacMove (true, id1, MoveAfter id2) -> - CT_move_after(xlate_hyp id1, xlate_hyp id2) - | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal" - | TacMove _ -> xlate_error "TODO: move before, at top, at bottom" - | TacIntroPattern patt_list -> - CT_intros - (CT_intro_patt_list (List.map xlate_intro_pattern patt_list)) - | TacIntroMove (Some id, MoveToEnd true) -> - CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) - | TacIntroMove (None, MoveToEnd true) -> - CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) - | TacIntroMove _ -> xlate_error "TODO" - | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl) - | TacRight (false,bindl) -> CT_right (xlate_bindings bindl) - | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl) - | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl) - | TacSplit _ | TacRight _ | TacLeft _ -> - xlate_error "TODO: esplit, eright, etc" - | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) -> - let c1 = xlate_formula (out_gen rawwit_constr c1) in - let c2 = xlate_formula (out_gen rawwit_constr c2) in - let cl = - (* J.F. : 18/08/2006 - Hack to coerce the "clause" argument of replace to a real clause - To be remove if we can reuse the clause grammar entrie defined in g_tactic - *) - let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in - let cl_as_xlate_arg = - {cl_as_clause with - Tacexpr.onhyps = - Option.map - (fun l -> - List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l - ) - cl_as_clause.Tacexpr.onhyps - } - in - cl_as_xlate_arg - in - let cl = xlate_clause cl in - let tac_opt = - match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with - | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | Some tac -> - let tac = xlate_tactic tac in - CT_coerce_TACTIC_COM_to_TACTIC_OPT tac - in - CT_replace_with (c1, c2,cl,tac_opt) - | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> - let cl = xlate_clause cl - and c = xlate_formula (fst cbindl) - and bindl = xlate_bindings (snd cbindl) in - if b then CT_rewrite_lr (c, bindl, cl) - else CT_rewrite_rl (c, bindl, cl) - | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by" - | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once" - | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite" - | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) -> - let t = out_gen rawwit_main_tactic t in - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) - else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) - | TacExtend (_,"conditional_rewrite", [t; b; cbindl; id]) -> - let t = out_gen rawwit_main_tactic t in - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in - if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id) - else CT_condrewrite_rl (xlate_tactic t, c, bindl, id) - | TacExtend (_,"dependent_rewrite", [b; c]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - (match c with - | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> - if b then CT_deprewrite_lr id else CT_deprewrite_rl id - | _ -> xlate_error "dependent rewrite on term: not supported") - | TacExtend (_,"dependent_rewrite", [b; c; id]) -> - xlate_error "dependent rewrite on terms in hypothesis: not supported" - | TacExtend (_,"cut_rewrite", [b; c]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) - else CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) - | TacExtend (_,"cut_rewrite", [b; c; id]) -> - let b = out_gen Extraargs.rawwit_orient b in - let c = xlate_formula (out_gen rawwit_constr c) in - let id = xlate_ident (snd (out_gen rawwit_var id)) in - if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) - else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) - | TacExtend(_, "subst", [l]) -> - CT_subst - (CT_id_list - (List.map (fun x -> CT_ident (string_of_id x)) - (out_gen (wit_list1 rawwit_ident) l))) - | TacReflexivity -> CT_reflexivity - | TacSymmetry cls -> CT_symmetry(xlate_clause cls) - | TacTransitivity c -> CT_transitivity (xlate_formula c) - | TacAssumption -> CT_assumption - | TacExact c -> CT_exact (xlate_formula c) - | TacExactNoCheck c -> CT_exact_no_check (xlate_formula c) - | TacVmCastNoCheck c -> CT_vm_cast_no_check (xlate_formula c) - | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) - | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) - | TacDestructConcl -> CT_dconcl - | TacSuperAuto (nopt,l,a3,a4) -> - CT_superauto( - xlate_int_opt nopt, - xlate_qualid_list l, - (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none), - (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none)) - | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt) - | TacAuto (nopt, [], Some []) -> CT_auto (xlate_int_or_var_opt_to_int_opt nopt) - | TacAuto (nopt, [], None) -> - CT_auto_with (xlate_int_or_var_opt_to_int_opt nopt, - CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | TacAuto (nopt, [], Some (id1::idl)) -> - CT_auto_with(xlate_int_or_var_opt_to_int_opt nopt, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( - CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl))) - | TacAuto (nopt, _::_, _) -> - xlate_error "TODO: auto using" - |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) -> - let (id_list:ct_ID list) = - List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in - let fst, (id_list1: ct_ID list) = - match id_list with [] -> assert false | a::tl -> a,tl in - let t1 = - match t with - [t0] -> - CT_coerce_TACTIC_COM_to_TACTIC_OPT - (xlate_tactic(out_gen rawwit_main_tactic t0)) - | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none - | _ -> assert false in - CT_autorewrite (CT_id_ne_list(fst, id_list1), t1) - | TacExtend (_,"eauto", [nopt; popt; lems; idl]) -> - let first_n = - match out_gen (wit_opt rawwit_int_or_var) nopt with - | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n - | None -> none_in_id_or_int_opt in - let second_n = - match out_gen (wit_opt rawwit_int_or_var) popt with - | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n - | None -> none_in_id_or_int_opt in - let _lems = - match out_gen Eauto.rawwit_auto_using lems with - | [] -> [] - | _ -> xlate_error "TODO: eauto using" in - let idl = out_gen Eauto.rawwit_hintbases idl in - (match idl with - None -> CT_eauto_with(first_n, - second_n, - CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | Some [] -> CT_eauto(first_n, second_n) - | Some (a::l) -> - CT_eauto_with(first_n, second_n, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR - (CT_id_ne_list - (CT_ident a, - List.map (fun x -> CT_ident x) l)))) - | TacExtend (_,"prolog", [cl; n]) -> - let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in - (match out_gen rawwit_int_or_var n with - | ArgVar _ -> xlate_error "" - | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) - (* eapply now represented by TacApply (true,cbindl) - | TacExtend (_,"eapply", [cbindl]) -> -*) - | TacTrivial ([],Some []) -> CT_trivial - | TacTrivial ([],None) -> - CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | TacTrivial ([],Some (id1::idl)) -> - CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( - (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl)))) - | TacTrivial (_::_,_) -> - xlate_error "TODO: trivial using" - | TacReduce (red, l) -> - CT_reduce (xlate_red_tactic red, xlate_clause l) - | TacApply (true,false,[c,bindl],None) -> - CT_apply (xlate_formula c, xlate_bindings bindl) - | TacApply (true,true,[c,bindl],None) -> - CT_eapply (xlate_formula c, xlate_bindings bindl) - | TacApply (_,_,_,_) -> - xlate_error "TODO: simple (e)apply and iterated apply and apply in" - | TacConstructor (false,n_or_meta, bindl) -> - let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" - in CT_constructor (CT_int n, xlate_bindings bindl) - | TacConstructor _ -> xlate_error "TODO: econstructor" - | TacSpecialize (nopt, (c,sl)) -> - CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl) - | TacGeneralize [] -> xlate_error "" - | TacGeneralize ((((true,[]),first),Anonymous) :: cl) - when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr - & na = Anonymous) cl -> - CT_generalize - (CT_formula_ne_list (xlate_formula first, - List.map (fun ((_,c),_) -> xlate_formula c) cl)) - | TacGeneralize _ -> xlate_error "TODO: Generalize at and as" - | TacGeneralizeDep c -> - CT_generalize_dependent (xlate_formula c) - | TacElimType c -> CT_elim_type (xlate_formula c) - | TacCaseType c -> CT_case_type (xlate_formula c) - | TacElim (false,(c1,sl), u) -> - CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u) - | TacCase (false,(c1,sl)) -> - CT_casetac (xlate_formula c1, xlate_bindings sl) - | TacElim (true,_,_) | TacCase (true,_) - | TacInductionDestruct (_,true,_) -> - xlate_error "TODO: eelim, ecase, edestruct, einduction" - | TacSimpleInductionDestruct (true,h) -> - CT_induction (xlate_quantified_hypothesis h) - | TacSimpleInductionDestruct (false,h) -> - CT_destruct (xlate_quantified_hypothesis h) - | TacCut c -> CT_cut (xlate_formula c) - | TacLApply c -> CT_use (xlate_formula c) - | TacDecompose ([],c) -> - xlate_error "Decompose : empty list of identifiers?" - | TacDecompose (id::l,c) -> - let id' = apply_or_by_notation tac_qualid_to_ct_ID id in - let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in - CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c) - | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c) - | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c) - | TacClear (false,[]) -> - xlate_error "Clear expects a non empty list of identifiers" - | TacClear (false,id::idl) -> - let idl' = List.map xlate_hyp idl in - CT_clear (CT_id_ne_list (xlate_hyp id, idl')) - | TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'" - | TacRevert _ -> xlate_error "TODO: revert" - | (*For translating tactics/Inv.v *) - TacInversion (NonDepInversion (k,idl,l),quant_hyp) -> - CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp, - xlate_with_names l, - CT_id_list (List.map xlate_hyp idl)) - | TacInversion (DepInversion (k,copt,l),quant_hyp) -> - let id = xlate_quantified_hypothesis quant_hyp in - CT_depinversion (compute_INV_TYPE k, id, - xlate_with_names l, xlate_formula_opt copt) - | TacInversion (InversionUsing (c,idlist), id) -> - let id = xlate_quantified_hypothesis id in - CT_use_inversion (id, xlate_formula c, - CT_id_list (List.map xlate_hyp idlist)) - | TacExtend (_,"omega", []) -> CT_omega - | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2) - | TacRename _ -> xlate_error "TODO: add support for n-ary rename" - | TacClearBody([]) -> assert false - | TacClearBody(a::l) -> - CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) - | TacDAuto (a, b, []) -> - CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) - | TacDAuto (a, b, _) -> - xlate_error "TODO: dauto using" - | TacInductionDestruct(true,false,[a,b,(None,c),None]) -> - CT_new_destruct - (List.map xlate_int_or_constr a, xlate_using b, - xlate_with_names c) - | TacInductionDestruct(false,false,[a,b,(None,c),None]) -> - CT_new_induction - (List.map xlate_int_or_constr a, xlate_using b, - xlate_with_names c) - | TacInductionDestruct(_,false,_) -> - xlate_error "TODO: clause 'in' and full 'as' of destruct/induction" - | TacLetTac (na, c, cl, true) when cl = nowhere -> - CT_pose(xlate_id_opt_aux na, xlate_formula c) - | TacLetTac (na, c, cl, true) -> - CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, - (* TODO LATER: This should be shared with Unfold, - but the structures are different *) - xlate_clause cl) - | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, Some (_,IntroIdentifier id), c) -> - CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, None, c) -> - CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> - CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), None, c) -> - CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert _ -> - xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" - | TacAnyConstructor(false,Some tac) -> - CT_any_constructor - (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) - | TacAnyConstructor(false,None) -> - CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) - | TacAnyConstructor _ -> xlate_error "TODO: econstructor" - | TacExtend(_, "ring", [args]) -> - CT_ring - (CT_formula_list - (List.map xlate_formula - (out_gen (wit_list0 rawwit_constr) args))) - | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal" - | TacExtend (_,id, l) -> - print_endline ("Extratactics : "^ id); - CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) - | TacAlias _ -> xlate_error "Alias not supported" - -and coerce_genarg_to_TARG x = - match Genarg.genarg_tag x with - (* Basic types *) - | BoolArgType -> xlate_error "TODO: generic boolean argument" - | IntArgType -> - let n = out_gen rawwit_int x in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_INT_to_ID_OR_INT (CT_int n))) - | IntOrVarArgType -> - let x = match out_gen rawwit_int_or_var x with - | ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) - | ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x) - | StringArgType -> - let s = CT_string (out_gen rawwit_string x) in - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT - (CT_coerce_STRING_to_ID_OR_STRING s)) - | PreIdentArgType -> - let id = CT_ident (out_gen rawwit_pre_ident x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | IntroPatternArgType -> - xlate_error "TODO" - | IdentArgType true -> - let id = xlate_ident (out_gen rawwit_ident x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | IdentArgType false -> - xlate_error "TODO" - | VarArgType -> - let id = xlate_ident (snd (out_gen rawwit_var x)) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - | RefArgType -> - let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in - CT_coerce_FORMULA_OR_INT_to_TARG - (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT - (CT_coerce_ID_to_ID_OR_INT id)) - (* Specific types *) - | SortArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT - (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) - | ConstrArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) - | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" - | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | OpenConstrArgType b -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula - (snd (out_gen - (rawwit_open_constr_gen b) x)))) - | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = Option.get (Pcoq.tactic_genarg_level s) in - let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in - CT_coerce_TACTIC_COM_to_TARG t - | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" - | BindingsArgType -> xlate_error "TODO: generic with bindings" - | RedExprArgType -> xlate_error "TODO: generic red expr" - | List0ArgType l -> xlate_error "TODO: lists of generic arguments" - | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" - | OptArgType x -> xlate_error "TODO: optional generic arguments" - | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" - | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" -and xlate_context_rule = - function - | Pat (hyps, concl_pat, tactic) -> - CT_context_rule - (CT_context_hyp_list (List.map xlate_match_context_hyps hyps), - xlate_context_pattern concl_pat, xlate_tactic tactic) - | All tactic -> - CT_def_context_rule (xlate_tactic tactic) -and formula_to_def_body = - function - | ConstrEval (red, f) -> - CT_coerce_EVAL_CMD_to_DEF_BODY( - CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, - xlate_red_tactic red, xlate_formula f)) - | ConstrContext((_, id), f) -> - CT_coerce_CONTEXT_PATTERN_to_DEF_BODY - (CT_context - (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)), - xlate_formula f)) - | ConstrTypeOf f -> CT_type_of (xlate_formula f) - | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) - -and mk_let_value = function - TacArg (ConstrMayEval v) -> - CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) - | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; - -let coerce_genarg_to_VARG x = - match Genarg.genarg_tag x with - (* Basic types *) - | BoolArgType -> xlate_error "TODO: generic boolean argument" - | IntArgType -> - let n = out_gen rawwit_int x in - CT_coerce_ID_OR_INT_OPT_to_VARG - (CT_coerce_INT_OPT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_INT_OPT (CT_int n))) - | IntOrVarArgType -> - (match out_gen rawwit_int_or_var x with - | ArgArg n -> - CT_coerce_ID_OR_INT_OPT_to_VARG - (CT_coerce_INT_OPT_to_ID_OR_INT_OPT - (CT_coerce_INT_to_INT_OPT (CT_int n))) - | ArgVar (_,id) -> - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT (xlate_ident id)))) - | StringArgType -> - let s = CT_string (out_gen rawwit_string x) in - CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s) - | PreIdentArgType -> - let id = CT_ident (out_gen rawwit_pre_ident x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | IntroPatternArgType -> - xlate_error "TODO" - | IdentArgType true -> - let id = xlate_ident (out_gen rawwit_ident x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | IdentArgType false -> - xlate_error "TODO" - | VarArgType -> - let id = xlate_ident (snd (out_gen rawwit_var x)) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - | RefArgType -> - let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in - CT_coerce_ID_OPT_OR_ALL_to_VARG - (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL - (CT_coerce_ID_to_ID_OPT id)) - (* Specific types *) - | SortArgType -> - CT_coerce_FORMULA_OPT_to_VARG - (CT_coerce_FORMULA_to_FORMULA_OPT - (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) - | ConstrArgType -> - CT_coerce_FORMULA_OPT_to_VARG - (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) - | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" - | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> - let n = Option.get (Pcoq.tactic_genarg_level s) in - let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in - CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) - | OpenConstrArgType _ -> xlate_error "TODO: generic open constr" - | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" - | BindingsArgType -> xlate_error "TODO: generic with bindings" - | RedExprArgType -> xlate_error "TODO: red expr as generic argument" - | List0ArgType l -> xlate_error "TODO: lists of generic arguments" - | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" - | OptArgType x -> xlate_error "TODO: optional generic arguments" - | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" - | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" - - -let xlate_thm x = CT_thm (string_of_theorem_kind x) - -let xlate_defn k = CT_defn (string_of_definition_kind k) - -let xlate_var x = CT_var (match x with - | (Global,Definitional) -> "Parameter" - | (Global,Logical) -> "Axiom" - | (Local,Definitional) -> "Variable" - | (Local,Logical) -> "Hypothesis" - | (Global,Conjectural) -> "Conjecture" - | (Local,Conjectural) -> xlate_error "No local conjecture");; - - -let xlate_dep = - function - | true -> CT_dep "Induction for" - | false -> CT_dep "Minimality for";; - -let xlate_locn = - function - | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n) - | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top") - | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev") - | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next") - -let xlate_search_restr = - function - | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none - | SearchInside (m1::l1) -> - CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, - List.map loc_qualid_to_ct_ID l1)) - | SearchOutside (m1::l1) -> - CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, - List.map loc_qualid_to_ct_ID l1)) - | SearchInside [] -> xlate_error "bad extra argument for Search" - -let xlate_check = - function - | "CHECK" -> "Check" - | "PRINTTYPE" -> "Type" - | _ -> xlate_error "xlate_check";; - -let build_constructors l = - let f (coe,((_,id),c)) = - if coe then CT_constr_coercion (xlate_ident id, xlate_formula c) - else CT_constr (xlate_ident id, xlate_formula c) in - CT_constr_list (List.map f l) - -let build_record_field_list l = - let build_record_field ((coe,d),not) = match d with - | AssumExpr (id,c) -> - if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) - else - CT_recconstr(xlate_id_opt id, xlate_formula c) - | DefExpr (id,c,topt) -> - if coe then - CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c, - xlate_formula_opt topt) - else - CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in - CT_recconstr_list (List.map build_record_field l);; - -let get_require_flags impexp spec = - let ct_impexp = - match impexp with - | None -> CT_coerce_NONE_to_IMPEXP CT_none - | Some false -> CT_import - | Some true -> CT_export in - let ct_spec = - match spec with - | None -> ctv_SPEC_OPT_NONE - | Some true -> CT_spec - | Some false -> ctv_SPEC_OPT_NONE in - ct_impexp, ct_spec;; - -let cvt_optional_eval_for_definition c1 optional_eval = - match optional_eval with - None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1) - | Some red -> - CT_coerce_EVAL_CMD_to_DEF_BODY( - CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, - xlate_red_tactic red, - xlate_formula c1)) - -let cvt_vernac_binder = function - | b,(id::idl,c) -> - let l,t = - CT_id_opt_ne_list - (xlate_ident_opt (Some (snd id)), - List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), - xlate_formula c in - if b then - CT_binder_coercion(l,t) - else - CT_binder(l,t) - | _, _ -> xlate_error "binder with no left part, rejected";; - -let cvt_vernac_binders = function - a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args) - | [] -> assert false;; - - -let xlate_comment = function - CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c) - | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT - (CT_coerce_STRING_to_ID_OR_STRING(CT_string s)) - | CommentInt n -> - CT_coerce_FORMULA_to_SCOMMENT_CONTENT - (CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));; - -let translate_opt_notation_decl = function - None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) - | Some(s, f, sc) -> - let tr_sc = - match sc with - None -> ctv_ID_OPT_NONE - | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in - CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; - -let xlate_level = function - Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n) - | Extend.NextLevel -> CT_next_level;; - -let xlate_syntax_modifier = function - Extend.SetItemLevel((s::sl), level) -> - CT_set_item_level - (CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl), - xlate_level level) - | Extend.SetItemLevel([], _) -> assert false - | Extend.SetLevel level -> CT_set_level (CT_int level) - | Extend.SetAssoc Gramext.LeftA -> CT_lefta - | Extend.SetAssoc Gramext.RightA -> CT_righta - | Extend.SetAssoc Gramext.NonA -> CT_nona - | Extend.SetEntryType(x,typ) -> - CT_entry_type(CT_ident x, - match typ with - Extend.ETIdent -> CT_ident "ident" - | Extend.ETReference -> CT_ident "global" - | Extend.ETBigint -> CT_ident "bigint" - | _ -> xlate_error "syntax_type not parsed") - | Extend.SetOnlyParsing -> CT_only_parsing - | Extend.SetFormat(_,s) -> CT_format(CT_string s);; - - -let rec xlate_module_type = function - | CMTEident(_, qid) -> - CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) - | CMTEwith(mty, decl) -> - let mty1 = xlate_module_type mty in - (match decl with - CWith_Definition((_, idl), c) -> - CT_module_type_with_def(mty1, - CT_id_list (List.map xlate_ident idl), - xlate_formula c) - | CWith_Module((_, idl), (_, qid)) -> - CT_module_type_with_mod(mty1, - CT_id_list (List.map xlate_ident idl), - CT_ident (xlate_qualid qid))) - | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";; - - -let xlate_module_binder_list (l:module_binder list) = - CT_module_binder_list - (List.map (fun (_, idl, mty) -> - let idl1 = - List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in - let fst,idl2 = match idl1 with - [] -> assert false - | fst::idl2 -> fst,idl2 in - CT_module_binder - (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);; - -let xlate_module_type_check_opt = function - None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK - (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) - | Some(mty, true) -> CT_only_check(xlate_module_type mty) - | Some(mty, false) -> - CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK - (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT - (xlate_module_type mty));; - -let rec xlate_module_expr = function - CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR - (CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid))) - | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1, - xlate_module_expr me2) - -let rec xlate_vernac = - function - | VernacDeclareTacticDefinition (true, tacs) -> - (match List.map - (function - (id, _, body) -> - CT_tac_def(reference_to_ct_ID id, xlate_tactic body)) - tacs with - [] -> assert false - | fst::tacs1 -> - CT_tactic_definition - (CT_tac_def_ne_list(fst, tacs1))) - | VernacDeclareTacticDefinition(false, _) -> - xlate_error "obsolete tactic definition not handled" - | VernacLoad (verbose,s) -> - CT_load ( - (match verbose with - | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none - | true -> CT_verbose), - CT_coerce_STRING_to_ID_OR_STRING (CT_string s)) - | VernacCheckMayEval (Some red, numopt, f) -> - let red = xlate_red_tactic red in - CT_coerce_EVAL_CMD_to_COMMAND - (CT_eval (xlate_int_opt numopt, red, xlate_formula f)) - |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s) - | VernacAddLoadPath (false,str,None) -> - CT_addpath (CT_string str, ctv_ID_OPT_NONE) - | VernacAddLoadPath (false,str,Some x) -> - CT_addpath (CT_string str, - CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) - | VernacAddLoadPath (true,str,None) -> - CT_recaddpath (CT_string str, ctv_ID_OPT_NONE) - | VernacAddLoadPath (_,str, Some x) -> - CT_recaddpath (CT_string str, - CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) - | VernacRemoveLoadPath str -> CT_delpath (CT_string str) - | VernacToplevelControl Quit -> CT_quit - | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported" - (*ML commands *) - | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str) - | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str) - | VernacDeclareMLModule [] -> failwith "" - | VernacDeclareMLModule (str :: l) -> - CT_ml_declare_modules - (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l)) - | VernacGoal c -> - CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c)) - | VernacAbort (Some (_,id)) -> - CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) - | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE - | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL - | VernacRestart -> CT_restart - | VernacSolve (n, tac, b) -> - CT_solve (CT_int n, xlate_tactic tac, - if b then CT_dotdot - else CT_coerce_NONE_to_DOTDOT_OPT CT_none) - -(* MMode *) - - | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> - anomaly "No MMode in CTcoq" - - -(* /MMode *) - - | VernacFocus nopt -> CT_focus (xlate_int_opt nopt) - | VernacUnfocus -> CT_unfocus - |VernacExtend("Extraction", [f;l]) -> - let file = out_gen rawwit_string f in - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in - CT_extract_to_file(CT_string file, - CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("ExtractionInline", [l]) -> - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in - CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("ExtractionNoInline", [l]) -> - let l1 = out_gen (wit_list1 rawwit_ref) l in - let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in - CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, - List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("Field", - [fth;ainv;ainvl;div]) -> - (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) - [fth;ainv;ainvl] - with - [fth1;ainv1;ainvl1] -> - let adiv1 = - xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in - CT_add_field(fth1, ainv1, ainvl1, adiv1) - |_ -> assert false) - | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) -> - let orient = out_gen Extraargs.rawwit_orient o in - let formula_list = out_gen (wit_list1 rawwit_constr) f in - let base = out_gen rawwit_pre_ident b in - let t = - match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId [] - in - let ct_orient = match orient with - | true -> CT_lr - | false -> CT_rl in - let f_ne_list = match List.map xlate_formula formula_list with - (fst::rest) -> CT_formula_ne_list(fst,rest) - | _ -> assert false in - CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) - | VernacCreateHintDb (local,dbname,b) -> - xlate_error "TODO: VernacCreateHintDb" - | VernacHints (local,dbnames,h) -> - let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in - (match h with - | HintsConstructors l -> - let n1, names = match List.map tac_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - if local then - CT_local_hints(CT_ident "Constructors", - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident "Constructors", - CT_id_ne_list(n1, names), dblist) - | HintsExtern (n, c, t) -> - let pat = match c with - | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) - | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) - in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) - | HintsImmediate l -> - let f1, formulas = match List.map xlate_formula l with - a :: tl -> a, tl - | _ -> failwith "" in - let l' = CT_formula_ne_list(f1, formulas) in - if local then - (match h with - HintsResolve _ -> - CT_local_hints_resolve(l', dblist) - | HintsImmediate _ -> - CT_local_hints_immediate(l', dblist) - | _ -> assert false) - else - (match h with - HintsResolve _ -> CT_hints_resolve(l', dblist) - | HintsImmediate _ -> CT_hints_immediate(l', dblist) - | _ -> assert false) - | HintsResolve l -> - let f1, formulas = match List.map xlate_formula (List.map pi3 l) with - a :: tl -> a, tl - | _ -> failwith "" in - let l' = CT_formula_ne_list(f1, formulas) in - if local then - (match h with - HintsResolve _ -> - CT_local_hints_resolve(l', dblist) - | HintsImmediate _ -> - CT_local_hints_immediate(l', dblist) - | _ -> assert false) - else - (match h with - HintsResolve _ -> CT_hints_resolve(l', dblist) - | HintsImmediate _ -> CT_hints_immediate(l', dblist) - | _ -> assert false) - | HintsUnfold l -> - let n1, names = match List.map loc_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - if local then - CT_local_hints(CT_ident "Unfold", - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - | HintsTransparency (l,b) -> - let n1, names = match List.map loc_qualid_to_ct_ID l with - n1 :: names -> n1, names - | _ -> failwith "" in - let ty = if b then "Transparent" else "Opaque" in - if local then - CT_local_hints(CT_ident ty, - CT_id_ne_list(n1, names), dblist) - else - CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) - | HintsDestruct(id, n, loc, f, t) -> - let dl = match loc with - ConclLocation() -> CT_conclusion_location - | HypLocation true -> CT_discardable_hypothesis - | HypLocation false -> CT_hypothesis_location in - if local then - CT_local_hint_destruct - (xlate_ident id, CT_int n, - dl, xlate_formula f, xlate_tactic t, dblist) - else - CT_hint_destruct - (xlate_ident id, CT_int n, dl, xlate_formula f, - xlate_tactic t, dblist) -) - | VernacEndProof (Proved (true,None)) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE) - | VernacEndProof (Proved (false,None)) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE) - | VernacEndProof (Proved (b,Some ((_,s), Some kind))) -> - CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind), - ctf_ID_OPT_SOME (xlate_ident s)) - | VernacEndProof (Proved (b,Some ((_,s),None))) -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), - ctf_ID_OPT_SOME (xlate_ident s)) - | VernacEndProof Admitted -> - CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE) - | VernacSetOpacity (_,l) -> - CT_strategy(CT_level_list - (List.map (fun (l,q) -> - (level_to_ct_LEVEL l, - CT_id_list(List.map loc_qualid_to_ct_ID q))) l)) - | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n)) - | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt) - | VernacShow ShowNode -> CT_show_node - | VernacShow ShowProof -> CT_show_proof - | VernacShow ShowTree -> CT_show_tree - | VernacShow ShowProofNames -> CT_show_proofs - | VernacShow (ShowIntros true) -> CT_show_intros - | VernacShow (ShowIntros false) -> CT_show_intro - | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1) - | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n) - | VernacShow ShowExistentials -> CT_show_existentials - | VernacShow ShowScript -> CT_show_script - | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)" - | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)" - | VernacGo arg -> CT_go (xlate_locn arg) - | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l) - | VernacShow (ExplainTree l) -> - CT_explain_prooftree (nums_to_int_list l) - | VernacCheckGuard -> CT_guarded - | VernacPrint p -> - (match p with - PrintFullContext -> CT_print_all - | PrintName id -> CT_print_id (loc_qualid_to_ct_ID id) - | PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id) - | PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id) - | PrintModules -> CT_print_modules - | PrintGrammar name -> CT_print_grammar CT_grammar_none - | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) - | PrintHintDbName id -> - CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) - | PrintRewriteHintDbName id -> - CT_print_rewrite_hintdb (CT_ident id) - | PrintHint id -> - CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) - | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE - | PrintLoadPath None -> CT_print_loadpath - | PrintLoadPath _ -> xlate_error "TODO: Print LoadPath dir" - | PrintMLLoadPath -> CT_ml_print_path - | PrintMLModules -> CT_ml_print_modules - | PrintGraph -> CT_print_graph - | PrintClasses -> CT_print_classes - | PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid) - | PrintCoercions -> CT_print_coercions - | PrintCoercionPaths (id1, id2) -> - CT_print_path (xlate_class id1, xlate_class id2) - | PrintCanonicalConversions -> - xlate_error "TODO: Print Canonical Structures" - | PrintAssumptions _ -> - xlate_error "TODO: Print Needed Assumptions" - | PrintInstances _ -> - xlate_error "TODO: Print Instances" - | PrintTypeClasses -> - xlate_error "TODO: Print TypeClasses" - | PrintInspect n -> CT_inspect (CT_int n) - | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) - | PrintTables -> CT_print_tables - | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) - | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) - | PrintScopes -> CT_print_scopes - | PrintScope id -> CT_print_scope (CT_ident id) - | PrintVisibility id_opt -> - CT_print_visibility - (match id_opt with - Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) - | None -> ctv_ID_OPT_NONE) - | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid) - | PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid)) - | VernacBeginSection (_,id) -> - CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id)) - | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id) - | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) -> - CT_coerce_THEOREM_GOAL_to_COMMAND( - CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, - xlate_binder_list bl, xlate_formula c)) - | VernacStartTheoremProof _ -> - xlate_error "TODO: Mutually dependent theorems" - | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt)) - | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> - CT_coerce_THEOREM_GOAL_to_COMMAND - (CT_theorem_goal - (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k), - xlate_ident s, xlate_binder_list bl, xlate_formula typ)) - | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) -> - CT_definition - (xlate_defn kind, xlate_ident s, xlate_binder_list bl, - cvt_optional_eval_for_definition c red_option, - xlate_formula_opt typ_opt) - | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline" - (*inline : bool -> automatic delta reduction at fonctor application*) - (* CT_variable (xlate_var kind, cvt_vernac_binders b)*) - | VernacCheckMayEval (None, numopt, c) -> - CT_check (xlate_formula c) - | VernacSearch (s,x) -> - let translated_restriction = xlate_search_restr x in - (match s with - | SearchPattern c -> - CT_search_pattern(xlate_formula c, translated_restriction) - | SearchHead id -> - CT_search(loc_qualid_to_ct_ID id, translated_restriction) - | SearchRewrite c -> - CT_search_rewrite(xlate_formula c, translated_restriction) - | SearchAbout (a::l) -> - let xlate_search_about_item (b,it) = - if not b then xlate_error "TODO: negative searchabout constraint"; - match it with - SearchSubPattern (CRef x) -> - CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString (s,None) -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string s) - | SearchString _ | SearchSubPattern _ -> - xlate_error - "TODO: search subpatterns or notation with explicit scope" - in - CT_search_about - (CT_id_or_string_ne_list(xlate_search_about_item a, - List.map xlate_search_about_item l), - translated_restriction) - | SearchAbout [] -> assert false) - -(* | (\*Record from tactics/Record.v *\) *) -(* VernacRecord *) -(* (_, (add_coercion, (_,s)), binders, c1, *) -(* rec_constructor_or_none, field_list) -> *) -(* let record_constructor = *) -(* xlate_ident_opt (Option.map snd rec_constructor_or_none) in *) -(* CT_record *) -(* ((if add_coercion then CT_coercion_atm else *) -(* CT_coerce_NONE_to_COERCION_OPT(CT_none)), *) -(* xlate_ident s, xlate_binder_list binders, *) -(* xlate_formula (Option.get c1), record_constructor, *) -(* build_record_field_list field_list) *) - | VernacInductive (isind, lmi) -> - let co_or_ind = if Decl_kinds.recursivity_flag_of_kind isind then "Inductive" else "CoInductive" in - let strip_mutind = function - (((_, (_,s)), parameters, c, _, Constructors constructors), notopt) -> - CT_ind_spec - (xlate_ident s, xlate_binder_list parameters, xlate_formula (Option.get c), - build_constructors constructors, - translate_opt_notation_decl notopt) - | _ -> xlate_error "TODO: Record notation in (Co)Inductive" in - CT_mind_decl - (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) - | VernacFixpoint ([],_) -> xlate_error "mutual recursive" - | VernacFixpoint ((lm :: lmi),boxed) -> - let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) = - let struct_arg = make_fix_struct (n, bl) in - let arf = xlate_formula arf in - let ardef = xlate_formula ardef in - match xlate_binder_list bl with - | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), - struct_arg, arf, ardef) - | _ -> xlate_error "mutual recursive" in - CT_fix_decl - (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) - | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" - | VernacCoFixpoint ((lm :: lmi),boxed) -> - let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) = - CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, - xlate_formula arf, xlate_formula ardef) in - CT_cofix_decl - (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)) - | VernacScheme [] -> xlate_error "induction scheme" - | VernacScheme (lm :: lmi) -> - let strip_ind = function - | (Some (_,id), InductionScheme (depstr, inde, sort)) -> - CT_scheme_spec - (xlate_ident id, xlate_dep depstr, - CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), - xlate_sort sort) - | (None, InductionScheme (depstr, inde, sort)) -> - CT_scheme_spec - (xlate_ident (id_of_string ""), xlate_dep depstr, - CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), - xlate_sort sort) - | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in - CT_ind_scheme - (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi)) - | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme" - | VernacSyntacticDefinition ((_,id), ([],c), false, _) -> - CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None) - | VernacSyntacticDefinition ((_,id), _, _, _) -> - xlate_error"TODO: Local abbreviations and abbreviations with parameters" - (* Modules and Module Types *) - | VernacInclude (_) -> xlate_error "TODO : Include " - | VernacDeclareModuleType((_, id), bl, mty_o) -> - CT_module_type_decl(xlate_ident id, - xlate_module_binder_list bl, - match mty_o with - None -> - CT_coerce_ID_OPT_to_MODULE_TYPE_OPT - ctv_ID_OPT_NONE - | Some mty1 -> - CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT - (xlate_module_type mty1)) - | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) -> - CT_module(xlate_ident id, - xlate_module_binder_list bl, - xlate_module_type_check_opt mty_o, - match mexpr_o with - None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE - | Some m -> xlate_module_expr m) - | VernacDeclareModule(_,(_, id), bl, mty_o) -> - CT_declare_module(xlate_ident id, - xlate_module_binder_list bl, - xlate_module_type_check_opt (Some mty_o), - CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE) - | VernacRequire (impexp, spec, id::idl) -> - let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require (ct_impexp, ct_spec, - CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( - CT_id_ne_list(loc_qualid_to_ct_ID id, - List.map loc_qualid_to_ct_ID idl))) - | VernacRequire (_,_,[]) -> - xlate_error "Require should have at least one id argument" - | VernacRequireFrom (impexp, spec, filename) -> - let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require(ct_impexp, ct_spec, - CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) - - | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) - | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) - | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) - | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) - | VernacArgumentsScope(true, qid, l) -> - CT_arguments_scope(loc_qualid_to_ct_ID qid, - CT_id_opt_list - (List.map - (fun x -> - match x with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) - | VernacArgumentsScope(false, qid, l) -> - xlate_error "TODO: Arguments Scope Global" - | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) - | VernacBindScope(id, a::l) -> - let xlate_class_rawexpr = function - FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" - | RefClass qid -> loc_qualid_to_ct_ID qid in - CT_bind_scope(CT_ident id, - CT_id_ne_list(xlate_class_rawexpr a, - List.map xlate_class_rawexpr l)) - | VernacBindScope(id, []) -> assert false - | VernacNotation(b, c, (s,modif_list), opt_scope) -> - let translated_s = CT_string s in - let formula = xlate_formula c in - let translated_modif_list = - CT_modifier_list(List.map xlate_syntax_modifier modif_list) in - let translated_scope = match opt_scope with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x) in - if b then - CT_local_define_notation - (translated_s, formula, translated_modif_list, translated_scope) - else - CT_define_notation(translated_s, formula, - translated_modif_list, translated_scope) - | VernacSyntaxExtension(b,(s,modif_list)) -> - let translated_s = CT_string s in - let translated_modif_list = - CT_modifier_list(List.map xlate_syntax_modifier modif_list) in - if b then - CT_local_reserve_notation(translated_s, translated_modif_list) - else - CT_reserve_notation(translated_s, translated_modif_list) - | VernacInfix (b,(str,modl),id, opt_scope) -> - let id1 = loc_qualid_to_ct_ID id in - let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in - let s = CT_string str in - let translated_scope = match opt_scope with - None -> ctv_ID_OPT_NONE - | Some x -> ctf_ID_OPT_SOME(CT_ident x) in - if b then - CT_local_infix(s, id1,modl1, translated_scope) - else - CT_infix(s, id1,modl1, translated_scope) - | VernacCoercion (s, id1, id2, id3) -> - let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in - let local_opt = - match s with - (* Cannot decide whether it is a global or a Local but at toplevel *) - | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none - | Local -> CT_local in - CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1, - xlate_class id2, xlate_class id3) - - | VernacIdentityCoercion (s, (_,id1), id2, id3) -> - let id_opt = CT_identity in - let local_opt = - match s with - (* Cannot decide whether it is a global or a Local but at toplevel *) - | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none - | Local -> CT_local in - CT_coercion (local_opt, id_opt, xlate_ident id1, - xlate_class id2, xlate_class id3) - - (* Type Classes *) - | VernacDeclareInstance _|VernacContext _| - VernacInstance (_, _, _, _, _) -> - xlate_error "TODO: Type Classes commands" - - | VernacResetName id -> CT_reset (xlate_ident (snd id)) - | VernacResetInitial -> CT_restore_state (CT_ident "Initial") - | VernacExtend (s, l) -> - CT_user_vernac - (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacList((_, a)::l) -> - CT_coerce_COMMAND_LIST_to_COMMAND - (CT_command_list(xlate_vernac a, - List.map (fun (_, x) -> xlate_vernac x) l)) - | VernacList([]) -> assert false - | VernacNop -> CT_proof_no_op - | VernacComments l -> - CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) - | VernacDeclareImplicits(true, id, opt_positions) -> - CT_implicits - (reference_to_ct_ID id, - match opt_positions with - None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none - | Some l -> - CT_coerce_ID_LIST_to_ID_LIST_OPT - (CT_id_list - (List.map - (function ExplByPos (x,_), _, _ - -> xlate_error - "explication argument by rank is obsolete" - | ExplByName id, _, _ -> CT_ident (string_of_id id)) l))) - | VernacDeclareImplicits(false, id, opt_positions) -> - xlate_error "TODO: Implicit Arguments Global" - | VernacReserve((_,a)::l, f) -> - CT_reserve(CT_id_ne_list(xlate_ident a, - List.map (fun (_,x) -> xlate_ident x) l), - xlate_formula f) - | VernacReserve([], _) -> assert false - | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id) - | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id) - | VernacLocate(LocateModule _) -> xlate_error "TODO: Locate Module" - | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s) - | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s) - | VernacTime(v) -> CT_time(xlate_vernac v) - | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) - |VernacExactProof f -> CT_proof(xlate_formula f) - | VernacSetOption (table, BoolValue true) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_set_option(table1) - | VernacSetOption (table, v) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - let value = - match v with - | BoolValue _ -> assert false - | StringValue s -> - CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s) - | IntValue n -> - CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in - CT_set_option_value(table1, value) - | VernacUnsetOption(table) -> - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_unset_option(table1) - | VernacAddOption (table, l) -> - let values = - List.map - (function - | QualidRefValue x -> - CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | StringRefValue x -> - CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in - let fst, values1 = - match values with [] -> assert false | a::b -> (a,b) in - let table1 = - match table with - PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) - | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) - | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in - CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1)) - | VernacImport(true, a::l) -> - CT_export_id(CT_id_ne_list(reference_to_ct_ID a, - List.map reference_to_ct_ID l)) - | VernacImport(false, a::l) -> - CT_import_id(CT_id_ne_list(reference_to_ct_ID a, - List.map reference_to_ct_ID l)) - | VernacImport(_, []) -> assert false - | VernacProof t -> CT_proof_with(xlate_tactic t) - | (VernacGlobalCheck _|VernacPrintOption _| - VernacMemOption (_, _)|VernacRemoveOption (_, _) - | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _| - VernacSolveExistential (_, _)|VernacCanonical _ | - VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _) - -> xlate_error "TODO: vernac" -and level_to_ct_LEVEL = function - Conv_oracle.Opaque -> CT_Opaque - | Conv_oracle.Level n -> CT_Level (CT_int n) - | Conv_oracle.Expand -> CT_Expand;; - - -let rec xlate_vernac_list = - function - | VernacList (v::l) -> - CT_command_list - (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l) - | VernacList [] -> xlate_error "xlate_command_list" - | _ -> xlate_error "Not a list of commands";; diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli deleted file mode 100644 index 2e2b95fe..00000000 --- a/contrib/interface/xlate.mli +++ /dev/null @@ -1,8 +0,0 @@ -open Ascent;; - -val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;; -val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;; -val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;; -val xlate_ident : Names.identifier -> ct_ID;; -val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;; - diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v deleted file mode 100644 index 93b4d213..00000000 --- a/contrib/micromega/CheckerMaker.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import Setoid. -Require Import Decidable. -Require Import List. -Require Import Refl. - -Set Implicit Arguments. - -Section CheckerMaker. - -(* 'Formula' is a syntactic representation of a certain kind of propositions. *) -Variable Formula : Type. - -Variable Env : Type. - -Variable eval : Env -> Formula -> Prop. - -Variable Formula' : Type. - -Variable eval' : Env -> Formula' -> Prop. - -Variable normalise : Formula -> Formula'. - -Variable negate : Formula -> Formula'. - -Hypothesis normalise_sound : - forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t). - -Hypothesis negate_correct : - forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)). - -Variable Witness : Type. - -Variable check_formulas' : list Formula' -> Witness -> bool. - -Hypothesis check_formulas'_sound : - forall (l : list Formula') (w : Witness), - check_formulas' l w = true -> - forall env : Env, make_impl (eval' env) l False. - -Definition normalise_list : list Formula -> list Formula' := map normalise. -Definition negate_list : list Formula -> list Formula' := map negate. - -Definition check_formulas (l : list Formula) (w : Witness) : bool := - check_formulas' (map normalise l) w. - -(* Contraposition of normalise_sound for lists *) -Lemma normalise_sound_contr : forall (env : Env) (l : list Formula), - make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False. -Proof. -intros env l; induction l as [| t l IH]; simpl in *. -trivial. -intros H1 H2. apply IH. apply H1. now apply normalise_sound. -Qed. - -Theorem check_formulas_sound : - forall (l : list Formula) (w : Witness), - check_formulas l w = true -> forall env : Env, make_impl (eval env) l False. -Proof. -unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *. -pose proof (check_formulas'_sound H env) as H1; now simpl in H1. -intro H1. apply normalise_sound in H1. -pose proof (check_formulas'_sound H env) as H2; simpl in H2. -apply H2 in H1. now apply normalise_sound_contr. -Qed. - -(* In check_conj_formulas', t2 is supposed to be a list of negations of -formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then -check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is -inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that -A1 /\ A2 -> B1 /\ B2. *) - -Fixpoint check_conj_formulas' - (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool := -match t2 with -| nil => true -| t':: rt2 => - match wits with - | nil => false - | w :: rwits => - match check_formulas' (t':: t1) w with - | true => check_conj_formulas' t1 rwits rt2 - | false => false - end - end -end. - -(* checks whether the conjunction of t1 implies the conjunction of t2 *) - -Definition check_conj_formulas - (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool := - check_conj_formulas' (normalise_list t1) wits (negate_list t2). - -Theorem check_conj_formulas_sound : - forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness), - check_conj_formulas t1 wits t2 = true -> - forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2). -Proof. -intro t1; induction t2 as [| a2 t2' IH]. -intros; apply make_impl_true. -intros wits H env. -unfold check_conj_formulas in H; simpl in H. -destruct wits as [| w ws]; simpl in H. discriminate. -case_eq (check_formulas' (negate a2 :: normalise_list t1) w); -intro H1; rewrite H1 in H; [| discriminate]. -assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by -now apply check_formulas'_sound with (w := w). clear H1. -pose proof (IH ws H env) as H1. simpl in H2. -assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False) -by auto using normalise_sound_contr. clear H2. -rewrite <- make_conj_impl in *. -rewrite make_conj_cons. intro H2. split. -apply <- negate_correct. intro; now elim H3. exact (H1 H2). -Qed. - -End CheckerMaker. diff --git a/contrib/micromega/Env.v b/contrib/micromega/Env.v deleted file mode 100644 index 40db9e46..00000000 --- a/contrib/micromega/Env.v +++ /dev/null @@ -1,182 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import ZArith. -Require Import Coq.Arith.Max. -Require Import List. -Set Implicit Arguments. - -(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) - -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. - BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. -*) - -Section S. - - Variable D :Type. - - Definition Env := positive -> D. - - Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j). - - Definition nth (n:positive) (e : Env ) := e n. - - Definition hd (x:D) (e: Env) := nth xH e. - - Definition tail (e: Env) := jump xH e. - - Lemma psucc : forall p, (match p with - | xI y' => xO (Psucc y') - | xO y' => xI y' - | 1%positive => 2%positive - end) = (p+1)%positive. - Proof. - destruct p. - auto with zarith. - rewrite xI_succ_xO. - auto with zarith. - reflexivity. - Qed. - - Lemma jump_Pplus : forall i j l, - forall x, jump (i + j) l x = jump i (jump j l) x. - Proof. - unfold jump. - intros. - rewrite Pplus_assoc. - reflexivity. - Qed. - - Lemma jump_simpl : forall p l, - forall x, jump p l x = - match p with - | xH => tail l x - | xO p => jump p (jump p l) x - | xI p => jump p (jump p (tail l)) x - end. - Proof. - destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. - (* xI p = p + p + 1 *) - rewrite xI_succ_xO. - rewrite Pplus_diag. - rewrite <- Pplus_one_succ_r. - reflexivity. - (* xO p = p + p *) - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - Ltac jump_s := - repeat - match goal with - | |- context [jump xH ?e] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) - end. - - Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x. - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Psucc : forall j l, - forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). - Proof. - intros. - rewrite <- jump_Pplus. - rewrite Pplus_one_succ_r. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Pdouble_minus_one : forall i l, - forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x. - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite <- Pplus_one_succ_r. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. - Qed. - - Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x. - Proof. - intros. - unfold jump. - unfold tail. - unfold jump. - rewrite <- Pplus_assoc. - simpl. - reflexivity. - Qed. - - Lemma nth_spec : forall p l x, - nth p l = - match p with - | xH => hd x l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - Proof. - unfold nth. - destruct p. - intros. - unfold jump, tail. - unfold jump. - rewrite Pplus_diag. - rewrite xI_succ_xO. - simpl. - reflexivity. - unfold jump. - rewrite Pplus_diag. - reflexivity. - unfold hd. - unfold nth. - reflexivity. - Qed. - - - Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l). - Proof. - unfold tail. - unfold hd. - unfold jump. - unfold nth. - intros. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). - Proof. - intros. - unfold tail. - unfold nth, jump. - rewrite Pplus_diag. - rewrite <- Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_one_succ_r. - reflexivity. - Qed. - -End S. - diff --git a/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v deleted file mode 100644 index 04e68272..00000000 --- a/contrib/micromega/EnvRing.v +++ /dev/null @@ -1,1403 +0,0 @@ -(************************************************************************) -(* V * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* F. Besson: to evaluate polynomials, the original code is using a list. - For big polynomials, this is inefficient -- linear access. - I have modified the code to use binary trees -- logarithmic access. *) - - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import Env. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Export Ring_theory. - -Open Local Scope positive_scope. -Import RingSyntax. - -Section MakeRingPol. - - (* Ring elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - - (* C notations *) - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - - (* Usefull tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match Pcompare j j' Eq with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match Pcompare i i' Eq with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Notation " P ?== P' " := (Peq P P'). - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj ((j + j'):positive) Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P:= - match j with - | xH => P - | xO j => Pinj (Pdouble_minus_one j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Notation "P ++ P'" := (Padd P P'). - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Notation "P -- P'" := (Psub P P'). - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. -(* A symmetric version of the multiplication *) - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - -(* Non symmetric *) -(* - Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := - match P' with - | Pc c' => PmulC P c' - | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => - (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) - end. - - Definition Pmul P P' := - match P with - | Pc c => PmulC P' c - | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => - (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') - end. -*) - Notation "P ** P'" := (Pmul P P'). - - Fixpoint Psquare (P:Pol) : Pol := - match P with - | Pc c => Pc (c *! c) - | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => - let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in - let Q2 := Psquare Q in - let P2 := Psquare P in - mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 - end. - - (** Monomial **) - - Inductive Mon: Set := - mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R := - match M with - mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi - end. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Ppred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := - match P, M with - _, mon0 => (Pc cO, P) - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) Eq with - Eq => let (R,S) := MFactor P1 M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 M in - let (R2, S2) := MFactor Q1 M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match (i ?= j) Eq with - Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := - let (Q1,R1) := MFactor P1 M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 M1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: - Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - (** Proofs *) - Lemma ZPminus_spec : forall x y, - match ZPminus x y with - | Z0 => x = y - | Zpos k => x = (y + k)%positive - | Zneg k => y = (x + k)%positive - end. - Proof. - induction x;destruct y. - replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - simpl;trivial. - replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. - replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - simpl;trivial. - Qed. - - Lemma Peq_ok : forall P P', - (P ?== P') = true -> forall l, P@l == P'@ l. - Proof. - induction P;destruct P';simpl;intros;try discriminate;trivial. - apply (morph_eq CRmorph);trivial. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite H1;trivial. clear H1. - assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); - destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] - |discriminate H]. - rewrite (H1 H);rewrite (H2 H);rrefl. - Qed. - - Lemma Pphi0 : forall l, P0@l == 0. - Proof. - intros;simpl;apply (morph0 CRmorph). - Qed. - -Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> - p @ e1 = p @ e2. -Proof. - induction p ; simpl. - reflexivity. - intros. - apply IHp. - intros. - unfold jump. - apply H. - intros. - rewrite (IHp1 e1 e2) ; auto. - rewrite (IHp2 (tail e1) (tail e2)) ; auto. - unfold hd. unfold nth. rewrite H. reflexivity. - unfold tail. unfold jump. intros ; apply H. -Qed. - -Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)). -Proof. - intros. apply env_morph. intros. rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. -Qed. - -Lemma Pjump_xO_tail : forall P p l, - P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). -Proof. - intros. - apply env_morph. - intros. - rewrite (@jump_simpl R (xI p)). - rewrite (@jump_simpl R (xO p)). - reflexivity. -Qed. - -Lemma Pjump_Pdouble_minus_one : forall P p l, - P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l). -Proof. - intros. - apply env_morph. - intros. - rewrite jump_Pdouble_minus_one. - rewrite (@jump_simpl R (xO p)). - reflexivity. -Qed. - - - - Lemma Pphi1 : forall l, P1@l == 1. - Proof. - intros;simpl;apply (morph1 CRmorph). - Qed. - - Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). - Proof. - intros j l p;destruct p;simpl;rsimpl. - rewrite Pjump_Pplus. - reflexivity. - Qed. - - Let pow_pos_Pplus := - pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). - - Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). - Proof. - intros l P i Q;unfold mkPX. - destruct P;try (simpl;rrefl). - assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. - rewrite (H (refl_equal true));rewrite (morph0 CRmorph). - rewrite mkPinj_ok;rsimpl;simpl;rrefl. - assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. - rewrite (H (refl_equal true));trivial. - rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. - Qed. - - - Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [P0@?l] => rewrite (Pphi0 l) - | |- context [P1@?l] => rewrite (Pphi1 l) - | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P) - | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q) - | |- context [[cO]] => rewrite (morph0 CRmorph) - | |- context [[cI]] => rewrite (morph1 CRmorph) - | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y) - | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y) - | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y) - | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x) - end)); - rsimpl; simpl. - - Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. - Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1;rewrite IHP2;rsimpl. - mul_push ([c]);rrefl. - Qed. - - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. - Proof. - intros c P l; unfold PmulC. - assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). - rewrite (H (refl_equal true));Esimpl. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok : forall P l, (--P)@l == - P@l. - Proof. - induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1;rewrite IHP2;rsimpl. - Qed. - - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) - | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - - - - - Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. - Proof. - induction P';simpl;intros;Esimpl2. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rrefl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite Pjump_Pplus. rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite Pjump_Pplus. rrefl. - destruct p0;simpl. - rewrite IHP2;simpl. rsimpl. - rewrite Pjump_xO_tail. Esimpl. - rewrite IHP2;simpl. - rewrite Pjump_Pdouble_minus_one. - rsimpl. - rewrite IHP'. - rsimpl. - destruct P;simpl. - Esimpl2;add_push [c];rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl. - rewrite Pjump_xO_tail. - rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;simpl. - rewrite Pjump_Pdouble_minus_one. rsimpl. - add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. - unfold tail. - add_push (P @ (jump 1 l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_comm ARth). - destruct p2; simpl; try apply (ARadd_comm ARth). - rewrite Pjump_xO_tail. - apply (ARadd_comm ARth). - rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth). - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. - rewrite IHP'1;simpl;Esimpl. - rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - Qed. - - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. - Proof. - induction P';simpl;intros;Esimpl2;trivial. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl. - rewrite IHP2;simpl. - rewrite Pjump_Pdouble_minus_one;rsimpl. - unfold tail ; rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. - rewrite Pjump_xO_tail. - add_push (P @ ((jump (xI p0) l)));rrefl. - rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. - unfold tail. - rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. - destruct p2;simpl; rewrite Popp_ok;rsimpl. - rewrite Pjump_xO_tail. - apply (ARadd_comm ARth);trivial. - rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth);trivial. - apply (ARadd_comm ARth);trivial. - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. - rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - Qed. -(* Proof for the symmetric version *) - - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : Env R), - (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pjump_Pplus;simpl;rrefl. - rewrite H1. - rewrite Pjump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;rsimpl. - rewrite Pjump_xO_tail. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one. - rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - -(* - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - - Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. - Proof. - induction P';simpl;intros. - Esimpl2;trivial. - apply PmulI_ok;trivial. - rewrite Padd_ok;Esimpl2. - rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. - Qed. -*) - -(* Proof for the symmetric version *) - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - intros P P';generalize P;clear P;induction P';simpl;intros. - apply PmulC_ok. apply PmulI_ok;trivial. - destruct P. - rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. - Esimpl2. rewrite IHP'1;Esimpl2. - assert (match p0 with - | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 - | 1 => P ** P'2 - end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). - destruct p0;rewrite IHP'2;Esimpl. - rewrite Pjump_xO_tail. reflexivity. - rewrite Pjump_Pdouble_minus_one;Esimpl. - rewrite H;Esimpl. - rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. - repeat (rewrite IHP'1 || rewrite IHP'2);simpl. - rewrite PmulI_ok;trivial. - unfold tail. - mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl. - Qed. - -(* -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - destruct P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_comm ARth). - rewrite Padd_ok; Esimpl2. - rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. - rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_comm ARth (P' @ l));rrefl. - Qed. -*) - - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. - Proof. - induction P;simpl;intros;Esimpl2. - apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. - rewrite IHP1;rewrite IHP2. - mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). - rrefl. - Qed. - - Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> - Mphi env P = Mphi env' P. - Proof. - induction P ; simpl. - reflexivity. - intros. - apply IHP. - intros. - unfold jump. - apply H. - (**) - intros. - replace (Mphi (tail env) P) with (Mphi (tail env') P). - unfold hd. unfold nth. - rewrite H. - reflexivity. - apply IHP. - unfold tail,jump. - intros. symmetry. apply H. - Qed. - -Lemma Mjump_xO_tail : forall M p l, - Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. -Proof. - intros. - apply Mphi_morph. - intros. - rewrite (@jump_simpl R (xI p)). - rewrite (@jump_simpl R (xO p)). - reflexivity. -Qed. - -Lemma Mjump_Pdouble_minus_one : forall M p l, - Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M. -Proof. - intros. - apply Mphi_morph. - intros. - rewrite jump_Pdouble_minus_one. - rewrite (@jump_simpl R (xO p)). - reflexivity. -Qed. - -Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M. -Proof. - intros. apply Mphi_morph. intros. rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. -Qed. - - - - Lemma mkZmon_ok: forall M j l, - Mphi l (mkZmon j M) == Mphi l (zmon j M). - intros M j l; case M; simpl; intros; rsimpl. - Qed. - - Lemma zmon_pred_ok : forall M j l, - Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). - Proof. - destruct j; simpl;intros l; rsimpl. - rewrite mkZmon_ok;rsimpl. - simpl. - rewrite Mjump_xO_tail. - reflexivity. - rewrite mkZmon_ok;simpl. - rewrite Mjump_Pdouble_minus_one; rsimpl. - Qed. - - Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. - Proof. - destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. - Qed. - - - Lemma Mphi_ok: forall P M l, - let (Q,R) := MFactor P M in - P@l == Q@l + (Mphi l M) * (R@l). - Proof. - intros P; elim P; simpl; auto; clear P. - intros c M l; case M; simpl; auto; try intro p; try intro m; - try rewrite (morph0 CRmorph); rsimpl. - - intros i P Hrec M l; case M; simpl; clear M. - rewrite (morph0 CRmorph); rsimpl. - intros j M. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec M (jump j l)); case (MFactor P M); - simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (zmon (j -i) M) (jump i l)); - case (MFactor P (zmon (j -i) M)); simpl. - intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). - rewrite Mjump_Pplus; auto. - rewrite (morph0 CRmorph); rsimpl. - intros P2 m; rewrite (morph0 CRmorph); rsimpl. - - intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. - rewrite (morph0 CRmorph); rsimpl. - intros j M1. - generalize (Hrec1 (zmon j M1) l); - case (MFactor P2 (zmon j M1)). - intros R1 S1 H1. - generalize (Hrec2 (zmon_pred j M1) (tail l)); - case (MFactor Q2 (zmon_pred j M1)); simpl. - intros R2 S2 H2; rewrite H1; rewrite H2. - repeat rewrite mkPX_ok; simpl. - rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - rewrite zmon_pred_ok;rsimpl. - intros j M1. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite mkZmon_ok. - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (vmon (j - i) M1) l); - case (MFactor P2 (vmon (j - i) M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (mkZmon 1 M1) l); - case (MFactor P2 (mkZmon 1 M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite mkZmon_ok. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - rewrite mkPX_ok; simpl; rsimpl. - rewrite (morph0 CRmorph); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite (ARmul_comm ARth (Q3@l)); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ He); rsimpl. - Qed. - -(* Proof for the symmetric version *) - - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. - Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - (* new version *) - rewrite Padd_ok; rewrite PmulC_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - assert (P4 = Q1 ++ P3 ** PX i P5 P6). - injection H2; intros; subst;trivial. - rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. -Qed. -(* - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. -Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok. - rewrite Pmul_ok; rsimpl. - Qed. -*) - Lemma PNSubst1_ok: forall n P1 M1 P2 l, - Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. - Proof. - intros n; elim n; simpl; auto. - intros P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. - intros n1 Hrec P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. - Qed. - - Lemma PNSubst_ok: forall n P1 M1 P2 l P3, - PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. - Proof. - intros n P2 M1 P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; discriminate]. - intros P5 H1; case n; try (intros; discriminate). - intros n1 H2; injection H2; intros; subst. - rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) - | _ => True - end. - - Lemma PSubstL1_ok: forall n LM1 P1 l, - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; rsimpl. - intros (M2,P2) LM2 Hrec P3 l [H H1]. - rewrite <- Hrec; auto. - apply PNSubst1_ok; auto. - Qed. - - Lemma PSubstL_ok: forall n LM1 P1 P2 l, - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; discriminate. - intros (M2,P2) LM2 Hrec P3 P4 l. - generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). - intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. - rewrite <- PSubstL1_ok; auto. - intros l1 H [H1 H2]; auto. - Qed. - - Lemma PNSubstL_ok: forall m n LM1 P1 l, - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - intros m; elim m; simpl; auto. - intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - intros m1 Hrec n LM1 P2 l H. - generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - rewrite <- Hrec; auto. - Qed. - - (** Definition of polynomial expressions *) - - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R := - match pe with - | PEc c => phi c - | PEX j => nth j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - - (** Correctness proofs *) - - Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - rewrite nth_spec ; auto. - unfold hd. - rewrite <- nth_Pdouble_minus_one. - rewrite (nth_jump (Pdouble_minus_one p) l 1). - reflexivity. - Qed. - - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). - -(* Power using the chinise algorithm *) -(*Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => P - | xO p => subst_l (Psquare (Ppow_pos P p)) - | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok P. - induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. - - End POWER. *) - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => subst_l (Pmul res P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. - rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (* - Fixpoint norm_subst (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => subst_l (mk_X j) - | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_subst pe1) (norm_subst pe2) - | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) - | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) - | PEopp pe1 => Popp (norm_subst pe1) - | PEpow pe1 n => Ppow_subst (norm_subst pe1) n - end. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). - unfold subst_l;intros. - rewrite <- PNSubstL_ok;trivial. rrefl. - assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). - intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. - induction pe;simpl;Esimpl3. - rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - unfold Ppow_subst. rewrite Ppow_N_ok. trivial. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - Qed. -*) - Lemma norm_aux_spec : - forall l pe, (*MPcond lmp l ->*) - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. - rewrite IHpe;rrefl. - rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - Qed. - - - End NORM_SUBST_REC. - - -End MakeRingPol. - diff --git a/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos deleted file mode 100644 index 5aadfa2a..00000000 --- a/contrib/micromega/LICENSE.sos +++ /dev/null @@ -1,29 +0,0 @@ - HOL Light copyright notice, licence and disclaimer - - (c) University of Cambridge 1998 - (c) Copyright, John Harrison 1998-2006 - -HOL Light version 2.20, hereinafter referred to as "the software", is a -computer theorem proving system written by John Harrison. Much of the -software was developed at the University of Cambridge Computer Laboratory, -New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The -software is copyright, University of Cambridge 1998 and John Harrison -1998-2006. - -Permission to use, copy, modify, and distribute the software and its -documentation for any purpose and without fee is hereby granted. In the -case of further distribution of the software the present text, including -copyright notice, licence and disclaimer of warranty, must be included in -full and unmodified form in any release. Distribution of derivative -software obtained by modifying the software, or incorporating it into -other software, is permitted, provided the inclusion of the software is -acknowledged and that any changes made to the software are clearly -documented. - -John Harrison and the University of Cambridge disclaim all warranties -with regard to the software, including all implied warranties of -merchantability and fitness. In no event shall John Harrison or the -University of Cambridge be liable for any special, indirect, -incidental or consequential damages or any damages whatsoever, -including, but not limited to, those arising from computer failure or -malfunction, work stoppage, loss of profit or loss of contracts. diff --git a/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v deleted file mode 100644 index a5ac92db..00000000 --- a/contrib/micromega/MExtraction.v +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -(* Used to generate micromega.ml *) - -Require Import ZMicromega. -Require Import QMicromega. -Require Import VarMap. -Require Import RingMicromega. -Require Import NArith. - -Extraction "micromega.ml" List.map simpl_cone map_cone indexes n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find. diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v deleted file mode 100644 index 149b7731..00000000 --- a/contrib/micromega/OrderedRing.v +++ /dev/null @@ -1,458 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import Setoid. -Require Import Ring. - -(** Generic properties of ordered rings on a setoid equality *) - -Set Implicit Arguments. - -Module Import OrderedRingSyntax. -Export RingSyntax. - -Reserved Notation "x ~= y" (at level 70, no associativity). -Reserved Notation "x [=] y" (at level 70, no associativity). -Reserved Notation "x [~=] y" (at level 70, no associativity). -Reserved Notation "x [<] y" (at level 70, no associativity). -Reserved Notation "x [<=] y" (at level 70, no associativity). -End OrderedRingSyntax. - -Section DEFINITIONS. - -Variable R : Type. -Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Record SOR : Type := mk_SOR_theory { - SORsetoid : Setoid_Theory R req; - SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2; - SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2); - SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2); - SORrt : ring_theory rO rI rplus rtimes rminus ropp req; - SORle_refl : forall n : R, n <= n; - SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m; - SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p; - SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m; - SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n; - SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m; - SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m; - SORneq_0_1 : 0 ~= 1 -}. - -(* We cannot use Relation_Definitions.order.ord_antisym and -Relations_1.Antisymmetric because they refer to Leibniz equality *) - -End DEFINITIONS. - -Section STRICT_ORDERED_RING. - -Variable R : Type. -Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R). -Variable req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - - -Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) -as sor_setoid. - - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact sor.(SORplus_wd). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact sor.(SORtimes_wd). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact sor.(SORopp_wd). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact sor.(SORle_wd). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact sor.(SORlt_wd). -Qed. - -Add Ring SOR : sor.(SORrt). - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. -intros x1 x2 H1 y1 y2 H2. -rewrite (sor.(SORrt).(Rsub_def) x1 y1). -rewrite (sor.(SORrt).(Rsub_def) x2 y2). -rewrite H1; now rewrite H2. -Qed. - -Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n. -Proof. -intros n m H1 H2; rewrite H2 in H1; now apply H1. -Qed. - -(* Propeties of plus, minus and opp *) - -Theorem Rplus_0_l : forall n : R, 0 + n == n. -Proof. -intro; ring. -Qed. - -Theorem Rplus_0_r : forall n : R, n + 0 == n. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_0_r : forall n : R, n * 0 == 0. -Proof. -intro; ring. -Qed. - -Theorem Rplus_comm : forall n m : R, n + m == m + n. -Proof. -intros; ring. -Qed. - -Theorem Rtimes_0_l : forall n : R, 0 * n == 0. -Proof. -intro; ring. -Qed. - -Theorem Rtimes_comm : forall n m : R, n * m == m * n. -Proof. -intros; ring. -Qed. - -Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. -Proof. -intros n m. -split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. -now rewrite Rplus_0_l. -rewrite H; ring. -Qed. - -Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m. -Proof. -intros n m p; split; intro H. -setoid_replace n with (- p + (p + n)) by ring. -setoid_replace m with (- p + (p + m)) by ring. now rewrite H. -now rewrite H. -Qed. - -(* Relations *) - -Theorem Rle_refl : forall n : R, n <= n. -Proof sor.(SORle_refl). - -Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m. -Proof sor.(SORle_antisymm). - -Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p. -Proof sor.(SORle_trans). - -Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n. -Proof sor.(SORlt_trichotomy). - -Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m. -Proof sor.(SORlt_le_neq). - -Theorem Rneq_0_1 : 0 ~= 1. -Proof sor.(SORneq_0_1). - -Theorem Req_em : forall n m : R, n == m \/ n ~= m. -Proof. -intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H. -right; now destruct H. -now left. -right; apply Rneq_symm; now destruct H. -Qed. - -Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m. -Proof. -intros n m; destruct (Req_em n m) as [H | H]. -split; auto. -split. intro H1; false_hyp H H1. auto. -Qed. - -Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m. -Proof. -intros n m; rewrite Rlt_le_neq. -split; [intro H | intros [[H1 H2] | H]]. -destruct (Req_em n m) as [H1 | H1]. now right. left; now split. -assumption. -rewrite H; apply Rle_refl. -Qed. - -Ltac le_less := rewrite Rle_lt_eq; left; try assumption. -Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption. -Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H]. - -Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p. -Proof. -intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split. -now apply Rle_trans with m. -intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4. -Qed. - -Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. -Proof. -intros n m p H1 H2; le_elim H1. -now apply Rlt_trans with (m := m). now rewrite H1. -Qed. - -Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. -Proof. -intros n m p H1 H2; le_elim H2. -now apply Rlt_trans with (m := m). now rewrite <- H2. -Qed. - -Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. -Proof. -intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]]. -left; now le_less. left; now le_equal. now right. -Qed. - -Theorem Rlt_neq : forall n m : R, n < m -> n ~= m. -Proof. -intros n m; rewrite Rlt_le_neq; now intros [_ H]. -Qed. - -Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n. -Proof. -intros n m; split. -intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2). -intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H. -Qed. - -Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n. -Proof. -intros n m; split. -intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2). -intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption. -Qed. - -(* Plus, minus and order *) - -Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m. -Proof. -intros n m p; split. -apply sor.(SORplus_le_mono_l). -intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H. -setoid_replace (- p + (p + n)) with n in H by ring. -setoid_replace (- p + (p + m)) with m in H by ring. assumption. -Qed. - -Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p. -Proof. -intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p). -apply Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m. -Proof. -intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l. -now rewrite <- Rplus_le_mono_l. -Qed. - -Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p. -Proof. -intros n m p. -rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l. -Qed. - -Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q. -Proof. -intros n m p q H1 H2. -apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l]. -Qed. - -Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q. -Proof. -intros n m p q H1 H2. -apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l]. -Qed. - -Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono. -Qed. - -Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono. -Qed. - -Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono. -Qed. - -Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m. -Proof. -intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono. -Qed. - -Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n. -Proof. -intros n m. rewrite (@Rplus_le_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n. -Proof. -intros n m. rewrite (@Rplus_lt_mono_r n m (- n)). -setoid_replace (n + - n) with 0 by ring. -now setoid_replace (m + - n) with (m - n) by ring. -Qed. - -Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n. -Proof. -intros n m. split; intro H. -apply -> (@Rplus_lt_mono_l n m (- n - m)) in H. -setoid_replace (- n - m + n) with (- m) in H by ring. -now setoid_replace (- n - m + m) with (- n) in H by ring. -apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H. -setoid_replace (n + m + - m) with n in H by ring. -now setoid_replace (n + m + - n) with m in H by ring. -Qed. - -Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0. -Proof. -intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring. -Qed. - -(* Times and order *) - -Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m. -Proof sor.(SORtimes_pos_pos). - -Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m. -Proof. -intros n m H1 H2. -le_elim H1. le_elim H2. -le_less; now apply Rtimes_pos_pos. -rewrite <- H2; rewrite Rtimes_0_r; le_equal. -rewrite <- H1; rewrite Rtimes_0_l; le_equal. -Qed. - -Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0. -Proof. -intros n m H1 H2. apply -> Ropp_pos_neg. -setoid_replace (- (n * m)) with (n * (- m)) by ring. -apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m. -Proof. -intros n m H1 H2. -setoid_replace (n * m) with ((- n) * (- m)) by ring. -apply Rtimes_pos_pos; now apply <- Ropp_pos_neg. -Qed. - -Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n. -Proof. -intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]]. -le_less; now apply Rtimes_pos_pos. -rewrite <- H, Rtimes_0_l; le_equal. -le_less; now apply Rtimes_neg_neg. -Qed. - -Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0. -Proof. -intros n m [H1 H2]. -destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]]; -destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]]; -try (false_hyp H3 H1); try (false_hyp H4 H2). -apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg. -apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg. -apply Rlt_neq. now apply Rtimes_pos_neg. -apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos. -Qed. - -(* The following theorems are used to build a morphism from Z to R and -prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *) - -(* Surprisingly, multilication is needed to prove the following theorem *) - -Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n. -Proof. -intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg. -now setoid_replace (- - n) with n by ring. -Qed. - -Theorem Rlt_0_1 : 0 < 1. -Proof. -apply <- Rlt_le_neq. split. -setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg. -apply Rneq_0_1. -Qed. - -Theorem Rlt_succ_r : forall n : R, n < 1 + n. -Proof. -intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring. -apply -> Rplus_lt_mono_r. apply Rlt_0_1. -Qed. - -Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m. -Proof. -intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r. -Qed. - -(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m. -Proof. -intros n m p H1 H2. apply <- Rlt_lt_minus. -setoid_replace (p * m - p * n) with (p * (m - n)) by ring. -apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus. -Qed.*) - -End STRICT_ORDERED_RING. - diff --git a/contrib/micromega/Psatz.v b/contrib/micromega/Psatz.v deleted file mode 100644 index b2dd9910..00000000 --- a/contrib/micromega/Psatz.v +++ /dev/null @@ -1,75 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import ZMicromega. -Require Import QMicromega. -Require Import RMicromega. -Require Import QArith. -Require Export Ring_normalize. -Require Import ZArith. -Require Import Raxioms. -Require Export RingMicromega. -Require Import VarMap. -Require Tauto. - -Ltac xpsatz dom d := - let tac := lazymatch dom with - | Z => - (sos_Z || psatz_Z d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | R => - (sos_R || psatz_R d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | Q => - (sos_Q || psatz_Q d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | _ => fail "Unsupported domain" - end in tac. - -Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. - -Ltac psatzl dom := - let tac := lazymatch dom with - | Z => - psatzl_Z ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | Q => - psatzl_Q ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | R => - psatzl_R ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | _ => fail "Unsupported domain" - end in tac. - - - -Ltac lia := - xlia ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. diff --git a/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v deleted file mode 100644 index c054f218..00000000 --- a/contrib/micromega/QMicromega.v +++ /dev/null @@ -1,199 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import Refl. -Require Import QArith. -Require Import Qfield. - -Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt. -Proof. - constructor; intros ; subst ; try (intuition (subst; auto with qarith)). - apply Q_Setoid. - rewrite H ; rewrite H0 ; reflexivity. - rewrite H ; rewrite H0 ; reflexivity. - rewrite H ; auto ; reflexivity. - rewrite <- H ; rewrite <- H0 ; auto. - rewrite H ; rewrite H0 ; auto. - rewrite <- H ; rewrite <- H0 ; auto. - rewrite H ; rewrite H0 ; auto. - apply Qsrt. - apply Qle_refl. - apply Qle_antisym ; auto. - eapply Qle_trans ; eauto. - apply Qlt_le_weak ; auto. - apply (Qlt_not_eq n m H H0) ; auto. - destruct (Qle_lt_or_eq _ _ H0) ; auto. - tauto. - destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto. - apply (Qplus_le_compat p p n m (Qle_refl p) H). - generalize (Qmult_lt_compat_r 0 n m H0 H). - rewrite Qmult_0_l. - auto. - compute in H. - discriminate. -Qed. - - -Lemma QSORaddon : - SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *) - 0 1 Qplus Qmult Qminus Qopp (* coefficients *) - Qeq_bool Qle_bool - (fun x => x) (fun x => x) (pow_N 1 Qmult). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Qeq_bool_eq; auto. - constructor. - reflexivity. - intros x y. - apply Qeq_bool_neq ; auto. - apply Qle_bool_imp_le. -Qed. - - -(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) -Require Import EnvRing. - -Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) - end. - -Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) - | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) - | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) - | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) - end. -Proof. - destruct e ; reflexivity. -Qed. - -Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n. -Proof. - destruct n ; reflexivity. -Qed. - - -Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e. -Proof. - induction e ; simpl ; subst ; try congruence. - rewrite IHe. - apply QNpower. -Qed. - -Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop := -match o with -| OpEq => Qeq -| OpNEq => fun x y => ~ x == y -| OpLe => Qle -| OpGe => fun x y => Qle y x -| OpLt => Qlt -| OpGt => fun x y => Qlt y x -end. - -Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) := - let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs). - -Definition Qeval_formula' := - eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f. -Proof. - intros. - unfold Qeval_formula. - destruct f. - repeat rewrite Qeval_expr_compat. - unfold Qeval_formula'. - unfold Qeval_expr'. - split ; destruct Fop ; simpl; auto. -Qed. - - - -Definition Qeval_nformula := - eval_nformula 0 Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult). - -Definition Qeval_op1 (o : Op1) : Q -> Prop := -match o with -| Equal => fun x : Q => x == 0 -| NonEqual => fun x : Q => ~ x == 0 -| Strict => fun x : Q => 0 < x -| NonStrict => fun x : Q => 0 <= x -end. - -Lemma Qeval_nformula_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)). -Proof. - intros. - destruct f. - rewrite Qeval_expr_compat. - reflexivity. -Qed. - -Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Qsor (fun x => x) (fun x => x) (pow_N 1 Qmult) env d). -Qed. - -Definition QWitness := ConeMember Q. - -Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. - -Require Import List. - -Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness), - QWeakChecker l cm = true -> - forall env, make_impl (Qeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Qeval_nformula. - apply (checker_nf_sound Qsor QSORaddon l cm). - unfold QWeakChecker in H. - exact H. -Qed. - -Require Import Tauto. - -Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q) QWitness QWeakChecker f w. - -Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f. -Proof. - intros f w. - unfold QTautoChecker. - apply (tauto_checker_sound Qeval_formula Qeval_nformula). - apply Qeval_nformula_dec. - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor). - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor). - intros t w0. - apply QWeakChecker_sound. -Qed. - - diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v deleted file mode 100644 index 7c6969c2..00000000 --- a/contrib/micromega/RMicromega.v +++ /dev/null @@ -1,174 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import Refl. -Require Import Raxioms RIneq Rpow_def DiscrR. -Require Setoid. - -Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R). -Proof. - constructor. - exact Rplus_0_l. - exact Rplus_comm. - intros. rewrite Rplus_assoc. auto. - exact Rmult_1_l. - exact Rmult_comm. - intros ; rewrite Rmult_assoc ; auto. - intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l. - rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto. - reflexivity. - exact Rplus_opp_r. -Qed. - -Add Ring Rring : Rsrt. -Open Scope R_scope. - -Lemma Rmult_neutral : forall x:R , 0 * x = 0. -Proof. - intro ; ring. -Qed. - - -Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. -Proof. - constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). - constructor. - constructor. - unfold RelationClasses.Symmetric. auto. - unfold RelationClasses.Transitive. intros. subst. reflexivity. - apply Rsrt. - eapply Rle_trans ; eauto. - apply (Rlt_irrefl m) ; auto. - apply Rnot_le_lt. auto with real. - destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - intros. - rewrite <- (Rmult_neutral m). - apply (Rmult_lt_compat_r) ; auto. -Qed. - -Require ZMicromega. - -(* R with coeffs in Z *) - -Lemma RZSORaddon : - SORaddon R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) - 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) - Zeq_bool Zle_bool - IZR Nnat.nat_of_N pow. -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply plus_IZR. - symmetry. apply Z_R_minus. - apply mult_IZR. - apply Ropp_Ropp_IZR. - apply IZR_eq. - apply Zeq_bool_eq ; auto. - apply R_power_theory. - intros x y. - intro. - apply IZR_neq. - apply Zeq_bool_neq ; auto. - intros. apply IZR_le. apply Zle_bool_imp_le. auto. -Qed. - - -Require Import EnvRing. - -Definition INZ (n:N) : R := - match n with - | N0 => IZR 0%Z - | Npos p => IZR (Zpos p) - end. - -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow. - - -Definition Reval_op2 (o:Op2) : R -> R -> Prop := - match o with - | OpEq => @eq R - | OpNEq => fun x y => ~ x = y - | OpLe => Rle - | OpGe => Rge - | OpLt => Rlt - | OpGt => Rgt - end. - - -Definition Reval_formula (e: PolEnv R) (ff : Formula Z) := - let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). - -Definition Reval_formula' := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. - -Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. -Proof. - intros. - unfold Reval_formula. - destruct f. - unfold Reval_formula'. - unfold Reval_expr. - split ; destruct Fop ; simpl ; auto. - apply Rge_le. - apply Rle_ge. -Qed. - -Definition Reval_nformula := - eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. - - -Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Rsor IZR Nnat.nat_of_N pow env d). -Qed. - -Definition RWitness := ConeMember Z. - -Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool Zle_bool. - -Require Import List. - -Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness), - RWeakChecker l cm = true -> - forall env, make_impl (Reval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Reval_nformula. - apply (checker_nf_sound Rsor RZSORaddon l cm). - unfold RWeakChecker in H. - exact H. -Qed. - -Require Import Tauto. - -Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := - @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z) RWitness RWeakChecker f w. - -Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. -Proof. - intros f w. - unfold RTautoChecker. - apply (tauto_checker_sound Reval_formula Reval_nformula). - apply Reval_nformula_dec. - intros. rewrite Reval_formula_compat. - unfold Reval_formula'. now apply (cnf_normalise_correct Rsor). - intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor). - intros t w0. - apply RWeakChecker_sound. -Qed. - - diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v deleted file mode 100644 index 801d8b21..00000000 --- a/contrib/micromega/Refl.v +++ /dev/null @@ -1,129 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import List. -Require Setoid. - -Set Implicit Arguments. - -(* Refl of '->' '/\': basic properties *) - -Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop := - match l with - | nil => goal - | cons e l => (eval e) -> (make_impl eval l goal) - end. - -Theorem make_impl_true : - forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. -Proof. -induction l as [| a l IH]; simpl. -trivial. -intro; apply IH. -Qed. - -Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop := - match l with - | nil => True - | cons e nil => (eval e) - | cons e l2 => ((eval e) /\ (make_conj eval l2)) - end. - -Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), - make_conj eval (a :: l) <-> eval a /\ make_conj eval l. -Proof. -intros; destruct l; simpl; tauto. -Qed. - - -Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), - (make_conj eval l -> g) <-> make_impl eval l g. -Proof. - induction l. - simpl. - tauto. - simpl. - intros. - destruct l. - simpl. - tauto. - generalize (IHl g). - tauto. -Qed. - -Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), - make_conj eval l -> (forall p, In p l -> eval p). -Proof. - induction l. - simpl. - tauto. - simpl. - intros. - destruct l. - simpl in H0. - destruct H0. - subst; auto. - tauto. - destruct H. - destruct H0. - subst;auto. - apply IHl; auto. -Qed. - - - -Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. -Proof. - induction l1. - simpl. - tauto. - intros. - change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). - rewrite make_conj_cons. - rewrite IHl1. - rewrite make_conj_cons. - tauto. -Qed. - -Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), - ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). -Proof. - intros. - simpl in H. - destruct a. - tauto. - tauto. -Qed. - -Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval - (no_middle_eval : forall d, eval d \/ ~ eval d) , - ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). -Proof. - induction t. - simpl. - tauto. - intros. - simpl ((a::t)++a0)in H. - destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). - left ; red ; intros. - apply H0. - rewrite make_conj_cons in H1. - tauto. - destruct (IHt _ _ no_middle_eval H0). - left ; red ; intros. - apply H1. - rewrite make_conj_cons in H2. - tauto. - right ; auto. -Qed. diff --git a/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v deleted file mode 100644 index 6885b82c..00000000 --- a/contrib/micromega/RingMicromega.v +++ /dev/null @@ -1,779 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import NArith. -Require Import Relation_Definitions. -Require Import Setoid. -(*****) -Require Import Env. -Require Import EnvRing. -(*****) -Require Import List. -Require Import Bool. -Require Import OrderedRing. -Require Import Refl. - - -Set Implicit Arguments. - -Import OrderedRingSyntax. - -Section Micromega. - -(* Assume we have a strict(ly?) ordered ring *) - -Variable R : Type. -Variables rO rI : R. -Variables rplus rtimes rminus: R -> R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -(* Assume we have a type of coefficients C and a morphism from C to R *) - -Variable C : Type. -Variables cO cI : C. -Variables cplus ctimes cminus: C -> C -> C. -Variable copp : C -> C. -Variables ceqb cleb : C -> C -> bool. -Variable phi : C -> R. - -(* Power coefficients *) -Variable E : Set. (* the type of exponents *) -Variable pow_phi : N -> E. -Variable rpow : R -> E -> R. - -Notation "[ x ]" := (phi x). -Notation "x [=] y" := (ceqb x y). -Notation "x [<=] y" := (cleb x y). - -(* Let's collect all hypotheses in addition to the ordered ring axioms into -one structure *) - -Record SORaddon := mk_SOR_addon { - SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi; - SORpower : power_theory rI rtimes req pow_phi rpow; - SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y]; - SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y] -}. - -Variable addon : SORaddon. - -Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ ) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ ) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ ) -as micomega_sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact sor.(SORplus_wd). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact sor.(SORtimes_wd). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact sor.(SORopp_wd). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. - exact sor.(SORle_wd). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. - exact sor.(SORlt_wd). -Qed. - -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *) -Qed. - -Definition cneqb (x y : C) := negb (ceqb x y). -Definition cltb (x y : C) := (cleb x y) && (cneqb x y). - -Notation "x [~=] y" := (cneqb x y). -Notation "x [<] y" := (cltb x y). - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. -Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H]. - -Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y]. -Proof. - exact addon.(SORcleb_morph). -Qed. - -Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y]. -Proof. -intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1. -destruct (ceqb x y); now try discriminate. -Qed. - -Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y]. -Proof. -intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2]. -apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split. -Qed. - -(* Begin Micromega *) - -Definition PExprC := PExpr C. (* arbitrary expressions built from +, *, - *) -Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) -(*****) -(*Definition Env := Env R. (* For interpreting PExprC *)*) -Definition PolEnv := Env R. (* For interpreting PolC *) -(*****) -(*Definition Env := list R. -Definition PolEnv := list R.*) -(*****) - -(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr -explicitely below and not through PEeval, as the following lemma says? The -function eval_pexpr seems to be a straightforward special case of PEeval -when the environment (i.e., the second last argument of PEeval) of type -off_map (which is (option positive * t)) is (None, env). *) - -(*****) -Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R := -match pe with -| PEc c => phi c -| PEX j => l j -| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2) -| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2) -| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2) -| PEopp pe1 => - (eval_pexpr l pe1) -| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n) -end. - - -Lemma eval_pexpr_simpl : forall (l : PolEnv) (pe : PExprC), - eval_pexpr l pe = - match pe with - | PEc c => phi c - | PEX j => l j - | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2) - | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2) - | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2) - | PEopp pe1 => - (eval_pexpr l pe1) - | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n) - end. -Proof. - intros ; destruct pe ; reflexivity. -Qed. - - - -Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC), - eval_pexpr env pe = - PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe. -Proof. -induction pe; simpl; intros. -reflexivity. -reflexivity. -rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. -rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. -rewrite <- IHpe1; rewrite <- IHpe2; reflexivity. -rewrite <- IHpe; reflexivity. -rewrite <- IHpe; reflexivity. -Qed. -(*****) -(*Definition eval_pexpr : Env -> PExprC -> R := - PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*) -(*****) - -Inductive Op1 : Set := (* relations with 0 *) -| Equal (* == 0 *) -| NonEqual (* ~= 0 *) -| Strict (* > 0 *) -| NonStrict (* >= 0 *). - -Definition NFormula := (PExprC * Op1)%type. (* normalized formula *) - -Definition eval_op1 (o : Op1) : R -> Prop := -match o with -| Equal => fun x => x == 0 -| NonEqual => fun x : R => x ~= 0 -| Strict => fun x : R => 0 < x -| NonStrict => fun x : R => 0 <= x -end. - -Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop := -let (p, op) := f in eval_op1 op (eval_pexpr env p). - - -Definition OpMult (o o' : Op1) : Op1 := -match o with -| Equal => Equal -| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *) -| Strict => o' -| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *) -end. - -Definition OpAdd (o o': Op1) : Op1 := -match o with -| Equal => o' -| NonStrict => - match o' with - | Strict => Strict - | _ => NonStrict - end -| Strict => Strict -| NonEqual => NonEqual (* does not matter what we return here *) -end. - -Lemma OpMultNonEqual : - forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual. -Proof. -intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate; -try (intro H; apply H1; reflexivity); -try (intro H; apply H2; reflexivity). -Qed. - -Lemma OpAdd_NonEqual : - forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual. -Proof. -intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate; -try (intro H; apply H1; reflexivity); -try (intro H; apply H2; reflexivity). -Qed. - -Lemma OpMult_sound : - forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual -> - eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y). -Proof. -unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4. -rewrite H3; now rewrite (Rtimes_0_l sor). -elimtype False; now apply H1. -destruct o'. -rewrite H4; now rewrite (Rtimes_0_r sor). -elimtype False; now apply H2. -now apply (Rtimes_pos_pos sor). -apply (Rtimes_nonneg_nonneg sor); [le_less | assumption]. -destruct o'. -rewrite H4, (Rtimes_0_r sor); le_equal. -elimtype False; now apply H2. -apply (Rtimes_nonneg_nonneg sor); [assumption | le_less]. -now apply (Rtimes_nonneg_nonneg sor). -Qed. - -Lemma OpAdd_sound : - forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual -> - eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e'). -Proof. -unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4. -destruct o'. -now rewrite H3, H4, (Rplus_0_l sor). -elimtype False; now apply H2. -now rewrite H3, (Rplus_0_l sor). -now rewrite H3, (Rplus_0_l sor). -elimtype False; now apply H1. -destruct o'. -now rewrite H4, (Rplus_0_r sor). -elimtype False; now apply H2. -now apply (Rplus_pos_pos sor). -now apply (Rplus_pos_nonneg sor). -destruct o'. -now rewrite H4, (Rplus_0_r sor). -elimtype False; now apply H2. -now apply (Rplus_nonneg_pos sor). -now apply (Rplus_nonneg_nonneg sor). -Qed. - -(* We consider a monoid whose generators are polynomials from the -hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that -every element of the monoid (i.e., arbitrary product of generators) is ~= -0. Therefore, the square of every element is > 0. *) - -Inductive Monoid (l : list NFormula) : PExprC -> Prop := -| M_One : Monoid l (PEc cI) -| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p -| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2). - -(* Do we really need to rely on the intermediate definition of monoid ? - InC why the restriction NonEqual ? - Could not we consider the IsIdeal as a IsMult ? - The same for IsSquare ? -*) - -Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop := -| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op -| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal -| IsSquare : forall p, Cone l (PEmul p p) NonStrict -| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict -| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq) -| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq) -| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict -| IsZ : Cone l (PEc cO) Equal. - -(* As promised, if all hypotheses are true in some environment, then every -member of the monoid is nonzero in this environment *) - -Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv), - (forall f : NFormula, In f l -> eval_nformula env f) -> - forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0. -Proof. -intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl. -rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor). -apply H1 in H. now simpl in H. -simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split. -Qed. - -(* If all members of a cone base are true in some environment, then every -member of the cone is true as well *) - -Lemma cone_true : - forall (l : list NFormula) (env : PolEnv), - (forall (f : NFormula), In f l -> eval_nformula env f) -> - forall (p : PExprC) (op : Op1), Cone l p op -> - op <> NonEqual /\ eval_nformula env (p, op). -Proof. -intros l env H1 p op H2. induction H2; simpl in *. -split. assumption. apply H1 in H. now unfold eval_nformula in H. -split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor). -split. discriminate. apply (Rtimes_square_nonneg sor). -split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor). -apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l. -destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4]. -split. now apply OpMultNonEqual. now apply OpMult_sound. -destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4]. -split. now apply OpAdd_NonEqual. now apply OpAdd_sound. -split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. -split. discriminate. apply addon.(SORrm).(morph0). -Qed. - -(* Every element of a monoid is a product of some generators; therefore, -to determine an element we can give a list of generators' indices *) - -Definition MonoidMember : Set := list nat. - -Inductive ConeMember : Type := -| S_In : nat -> ConeMember -| S_Ideal : PExprC -> ConeMember -> ConeMember -| S_Square : PExprC -> ConeMember -| S_Monoid : MonoidMember -> ConeMember -| S_Mult : ConeMember -> ConeMember -> ConeMember -| S_Add : ConeMember -> ConeMember -> ConeMember -| S_Pos : C -> ConeMember -| S_Z : ConeMember. - -Definition nformula_times (f f' : NFormula) : NFormula := -let (p, op) := f in - let (p', op') := f' in - (PEmul p p', OpMult op op'). - -Definition nformula_plus (f f' : NFormula) : NFormula := -let (p, op) := f in - let (p', op') := f' in - (PEadd p p', OpAdd op op'). - -Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula := -let (q, op) := f in - match op with - | Equal => (PEmul q p, Equal) - | _ => f - end. - -Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC := -match ns with -| nil => PEc cI -| n :: ns => - let p := match nth n l (PEc cI, NonEqual) with - | (q, NonEqual) => q - | _ => PEc cI - end in - PEmul p (eval_monoid l ns) -end. - -Theorem eval_monoid_in_monoid : - forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns). -Proof. -intro l; induction ns; simpl in *. -constructor. -apply M_Mult; [| assumption]. -destruct (nth_in_or_default a l (PEc cI, NonEqual)). -destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption. -rewrite e; simpl. constructor. -Qed. - -(* Provides the cone member from the witness, i.e., ConeMember *) -Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula := -match cm with -| S_In n => match nth n l (PEc cO, Equal) with - | (_, NonEqual) => (PEc cO, Equal) - | f => f - end -| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm') -| S_Square p => (PEmul p p, NonStrict) -| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict) -| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q) -| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q) -| S_Pos c => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal) -| S_Z => (PEc cO, Equal) -end. - -Theorem eval_cone_in_cone : - forall (l : list NFormula) (cm : ConeMember), - let (p, op) := eval_cone l cm in Cone l p op. -Proof. -intros l cm; induction cm; simpl. -destruct (nth_in_or_default n l (PEc cO, Equal)). -destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ. -rewrite e. apply IsZ. -destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal. -apply IsSquare. -apply IsMonoid. apply eval_monoid_in_monoid. -destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult. -destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd. -case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ]. -apply IsZ. -Qed. - -(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op -(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact -implies that l is inconsistent, as shown by the next lemma. Inconsistency -of a formula (p, op) can be established by normalizing p and showing that -it is a constant c for which (c, op) is false. (This is only a sufficient, -not necessary, condition, of course.) Membership in the cone can be -verified if we have a certificate. *) - -Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) := - exists op : Op1, Cone l p op /\ - forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p). - -(* If some element of a cone is inconsistent, then the base of the cone -is also inconsistent *) - -Lemma prove_inconsistent : - forall (l : list NFormula) (p : PExprC), - inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False. -Proof. -intros l p H env. -destruct H as [o [wit H]]. -apply -> make_conj_impl. -intro H1. apply H with env. -pose proof (@cone_true l env) as H2. -cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3. -apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in. -Qed. - -Definition normalise_pexpr : PExprC -> PolC := - norm_aux cO cI cplus ctimes cminus copp ceqb. - -(* The following definition we don't really need, hence it is commented *) -(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*) - -(* roughly speaking, normalise_pexpr_correct is a proof of - forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) - -(*****) -Definition normalise_pexpr_correct := -let Rops_wd := mk_reqe rplus rtimes ropp req - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) - addon.(SORrm) addon.(SORpower). -(*****) -(*Definition normalise_pexpr_correct := -let Rops_wd := mk_reqe rplus rtimes ropp req - sor.(SORplus_wd) - sor.(SORtimes_wd) - sor.(SORopp_wd) in - norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt)) - addon.(SORrm) addon.(SORpower) nil.*) -(*****) - -(* Check that a formula f is inconsistent by normalizing and comparing the -resulting constant with 0 *) - -Definition check_inconsistent (f : NFormula) : bool := -let (e, op) := f in - match normalise_pexpr e with - | Pc c => - match op with - | Equal => cneqb c cO - | NonStrict => c [<] cO - | Strict => c [<=] cO - | NonEqual => false (* eval_cone never returns (p, NonEqual) *) - end - | _ => false (* not a constant *) - end. - -Lemma check_inconsistent_sound : - forall (p : PExprC) (op : Op1), - check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p). -Proof. -intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1. -destruct op; simpl; -(*****) -rewrite eval_pexpr_PEeval; -(*****) -(*unfold eval_pexpr;*) -(*****) -rewrite normalise_pexpr_correct; -destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1; -try rewrite <- addon.(SORrm).(morph0); trivial. -now apply cneqb_sound. -apply cleb_sound in H1. now apply -> (Rle_ngt sor). -apply cltb_sound in H1. now apply -> (Rlt_nge sor). -Qed. - -Definition check_normalised_formulas : list NFormula -> ConeMember -> bool := - fun l cm => check_inconsistent (eval_cone l cm). - -Lemma checker_nf_sound : - forall (l : list NFormula) (cm : ConeMember), - check_normalised_formulas l cm = true -> - forall env : PolEnv, make_impl (eval_nformula env) l False. -Proof. -intros l cm H env. -unfold check_normalised_formulas in H. -case_eq (eval_cone l cm). intros p op H1. -apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split. -pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2. -apply check_inconsistent_sound. now rewrite <- H1. -Qed. - -(** Normalisation of formulae **) - -Inductive Op2 : Set := (* binary relations *) -| OpEq -| OpNEq -| OpLe -| OpGe -| OpLt -| OpGt. - -Definition eval_op2 (o : Op2) : R -> R -> Prop := -match o with -| OpEq => req -| OpNEq => fun x y : R => x ~= y -| OpLe => rle -| OpGe => fun x y : R => y <= x -| OpLt => fun x y : R => x < y -| OpGt => fun x y : R => y < x -end. - -Record Formula : Type := { - Flhs : PExprC; - Fop : Op2; - Frhs : PExprC -}. - -Definition eval_formula (env : PolEnv) (f : Formula) : Prop := - let (lhs, op, rhs) := f in - (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). - -(* We normalize Formulas by moving terms to one side *) - -Definition normalise (f : Formula) : NFormula := -let (lhs, op, rhs) := f in - match op with - | OpEq => (PEsub lhs rhs, Equal) - | OpNEq => (PEsub lhs rhs, NonEqual) - | OpLe => (PEsub rhs lhs, NonStrict) - | OpGe => (PEsub lhs rhs, NonStrict) - | OpGt => (PEsub lhs rhs, Strict) - | OpLt => (PEsub rhs lhs, Strict) - end. - -Definition negate (f : Formula) : NFormula := -let (lhs, op, rhs) := f in - match op with - | OpEq => (PEsub rhs lhs, NonEqual) - | OpNEq => (PEsub rhs lhs, Equal) - | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *) - | OpGe => (PEsub rhs lhs, Strict) - | OpGt => (PEsub rhs lhs, NonStrict) - | OpLt => (PEsub lhs rhs, NonStrict) -end. - -Theorem normalise_sound : - forall (env : PolEnv) (f : Formula), - eval_formula env f -> eval_nformula env (normalise f). -Proof. -intros env f H; destruct f as [lhs op rhs]; simpl in *. -destruct op; simpl in *. -now apply <- (Rminus_eq_0 sor). -intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. -now apply -> (Rle_le_minus sor). -now apply -> (Rle_le_minus sor). -now apply -> (Rlt_lt_minus sor). -now apply -> (Rlt_lt_minus sor). -Qed. - -Theorem negate_correct : - forall (env : PolEnv) (f : Formula), - eval_formula env f <-> ~ (eval_nformula env (negate f)). -Proof. -intros env f; destruct f as [lhs op rhs]; simpl. -destruct op; simpl. -symmetry. rewrite (Rminus_eq_0 sor). -split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. -rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -Qed. - -(** Another normalistion - this is used for cnf conversion **) - -Definition xnormalise (t:Formula) : list (NFormula) := - let (lhs,o,rhs) := t in - match o with - | OpEq => - (PEsub lhs rhs, Strict)::(PEsub rhs lhs , Strict)::nil - | OpNEq => (PEsub lhs rhs,Equal) :: nil - | OpGt => (PEsub rhs lhs,NonStrict) :: nil - | OpLt => (PEsub lhs rhs,NonStrict) :: nil - | OpGe => (PEsub rhs lhs , Strict) :: nil - | OpLe => (PEsub lhs rhs ,Strict) :: nil - end. - -Require Import Tauto. - -Definition cnf_normalise (t:Formula) : cnf (NFormula) := - List.map (fun x => x::nil) (xnormalise t). - - -Add Ring SORRing : sor.(SORrt). - -Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t. -Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros env t. - unfold eval_cnf. - destruct t as [lhs o rhs]; case_eq o ; simpl; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - (**) - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - now rewrite <- (Rminus_eq_0 sor). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. -Qed. - -Definition xnegate (t:Formula) : list (NFormula) := - let (lhs,o,rhs) := t in - match o with - | OpEq => (PEsub lhs rhs,Equal) :: nil - | OpNEq => (PEsub lhs rhs ,Strict)::(PEsub rhs lhs,Strict)::nil - | OpGt => (PEsub lhs rhs,Strict) :: nil - | OpLt => (PEsub rhs lhs,Strict) :: nil - | OpGe => (PEsub lhs rhs,NonStrict) :: nil - | OpLe => (PEsub rhs lhs,NonStrict) :: nil - end. - -Definition cnf_negate (t:Formula) : cnf (NFormula) := - List.map (fun x => x::nil) (xnegate t). - -Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t. -Proof. - unfold cnf_negate, xnegate ; simpl ; intros env t. - unfold eval_cnf. - destruct t as [lhs o rhs]; case_eq o ; simpl ; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; - intuition. - (**) - apply H0. - rewrite H1 ; ring. - (**) - apply H1. - apply sor.(SORle_antisymm). - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - (**) - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rle_le_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - apply H0. now rewrite (Rlt_lt_minus sor) in H1. -Qed. - - -Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). -Proof. - intros. - destruct d ; simpl. - generalize (eval_pexpr env p); intros. - destruct o ; simpl. - apply (Req_em sor r 0). - destruct (Req_em sor r 0) ; tauto. - rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. - rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto. -Qed. - -(** Some syntactic simplifications of expressions and cone elements *) - - -Fixpoint simpl_expr (e:PExprC) : PExprC := - match e with - | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in - match y' , z' with - | PEc c , z' => if ceqb c cI then z' else PEmul y' z' - | _ , _ => PEmul y' z' - end - | PEadd x y => PEadd (simpl_expr x) (simpl_expr y) - | _ => e - end. - - -Definition simpl_cone (e:ConeMember) : ConeMember := - match e with - | S_Square t => match simpl_expr t with - | PEc c => if ceqb cO c then S_Z else S_Pos (ctimes c c) - | x => S_Square x - end - | S_Mult t1 t2 => - match t1 , t2 with - | S_Z , x => S_Z - | x , S_Z => S_Z - | S_Pos c , S_Pos c' => S_Pos (ctimes c c') - | S_Pos p1 , S_Mult (S_Pos p2) x => S_Mult (S_Pos (ctimes p1 p2)) x - | S_Pos p1 , S_Mult x (S_Pos p2) => S_Mult (S_Pos (ctimes p1 p2)) x - | S_Mult (S_Pos p2) x , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x - | S_Mult x (S_Pos p2) , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x - | S_Pos x , S_Add y z => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z) - | S_Pos c , _ => if ceqb cI c then t2 else S_Mult t1 t2 - | _ , S_Pos c => if ceqb cI c then t1 else S_Mult t1 t2 - | _ , _ => e - end - | S_Add t1 t2 => - match t1 , t2 with - | S_Z , x => x - | x , S_Z => x - | x , y => S_Add x y - end - | _ => e - end. - - - -End Micromega. - diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v deleted file mode 100644 index ef48efa6..00000000 --- a/contrib/micromega/Tauto.v +++ /dev/null @@ -1,324 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import List. -Require Import Refl. -Require Import Bool. - -Set Implicit Arguments. - - - Inductive BFormula (A:Type) : Type := - | TT : BFormula A - | FF : BFormula A - | X : Prop -> BFormula A - | A : A -> BFormula A - | Cj : BFormula A -> BFormula A -> BFormula A - | D : BFormula A-> BFormula A -> BFormula A - | N : BFormula A -> BFormula A - | I : BFormula A-> BFormula A-> BFormula A. - - Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := - match f with - | TT => True - | FF => False - | A a => ev a - | X p => p - | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2) - | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2) - | N e => ~ (eval_f ev e) - | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) - end. - - - Lemma map_simpl : forall A B f l, @map A B f l = match l with - | nil => nil - | a :: l=> (f a) :: (@map A B f l) - end. - Proof. - destruct l ; reflexivity. - Qed. - - - - Section S. - - Variable Env : Type. - Variable Term : Type. - Variable eval : Env -> Term -> Prop. - Variable Term' : Type. - Variable eval' : Env -> Term' -> Prop. - - - - Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). - - - Definition clause := list Term'. - Definition cnf := list clause. - - Variable normalise : Term -> cnf. - Variable negate : Term -> cnf. - - - Definition tt : cnf := @nil clause. - Definition ff : cnf := cons (@nil Term') nil. - - - Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. - - Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := - match f with - | nil => tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') - end. - - - Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := - f1 ++ f2. - - Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := - match f with - | TT => if pol then tt else ff - | FF => if pol then ff else tt - | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) - | A x => if pol then normalise x else negate x - | N e => xcnf (negb pol) e - | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) - end. - - Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f. - - - Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y. - Proof. - unfold eval_cnf. - intros. - rewrite make_conj_app in H ; auto. - Qed. - - - Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f). - Proof. - unfold eval_cnf. - unfold or_clause_cnf. - induction f. - simpl. - intros ; right;auto. - (**) - rewrite map_simpl. - intros. - rewrite make_conj_cons in H. - destruct H as [HH1 HH2]. - generalize (IHf HH2) ; clear IHf ; intro. - destruct H. - left ; auto. - rewrite make_conj_cons. - destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1). - tauto. - tauto. - Qed. - - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f). - Proof. - intros. - unfold eval_cnf in *. - rewrite make_conj_cons ; eauto. - Qed. - - Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f'). - Proof. - induction f. - unfold eval_cnf. - simpl. - tauto. - (**) - intros. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - clear H. - destruct (IHf _ H0). - destruct (or_clause_correct _ _ _ H1). - left. - apply eval_cnf_cons ; auto. - right ; auto. - right ; auto. - Qed. - - Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t. - - Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t. - - - Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). - Proof. - induction f. - (* TT *) - unfold eval_cnf. - simpl. - destruct pol ; simpl ; auto. - (* FF *) - unfold eval_cnf. - destruct pol; simpl ; auto. - (* P *) - simpl. - destruct pol ; intros ;simpl. - unfold eval_cnf in H. - (* Here I have to drop the proposition *) - simpl in H. - tauto. - (* Here, I could store P in the clause *) - unfold eval_cnf in H;simpl in H. - tauto. - (* A *) - simpl. - destruct pol ; simpl. - intros. - apply normalise_correct ; auto. - (* A 2 *) - intros. - apply negate_correct ; auto. - auto. - (* Cj *) - destruct pol ; simpl. - (* pol = true *) - intros. - unfold and_cnf in H. - destruct (eval_cnf_app _ _ _ H). - clear H. - split. - apply (IHf1 _ _ H0). - apply (IHf2 _ _ H1). - (* pol = false *) - intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 false env H0). - simpl. - tauto. - generalize (IHf2 false env H0). - simpl. - tauto. - (* D *) - simpl. - destruct pol. - (* pol = true *) - intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ env H0). - simpl. - tauto. - generalize (IHf2 _ env H0). - simpl. - tauto. - (* pol = true *) - unfold and_cnf. - intros. - destruct (eval_cnf_app _ _ _ H). - clear H. - simpl. - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. - (**) - simpl. - destruct pol ; simpl. - intros. - apply (IHf false) ; auto. - intros. - generalize (IHf _ _ H). - tauto. - (* I *) - simpl; intros. - destruct pol. - simpl. - intro. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ _ H1). - simpl in *. - tauto. - generalize (IHf2 _ _ H1). - auto. - (* pol = false *) - unfold and_cnf in H. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. - Qed. - - - Variable Witness : Type. - Variable checker : list Term' -> Witness -> bool. - - Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. - - Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := - match f with - | nil => true - | e::f => match l with - | nil => false - | c::l => match checker e c with - | true => cnf_checker f l - | _ => false - end - end - end. - - Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t. - Proof. - unfold eval_cnf. - induction t. - (* bc *) - simpl. - auto. - (* ic *) - simpl. - destruct w. - intros ; discriminate. - case_eq (checker a w) ; intros ; try discriminate. - generalize (@checker_sound _ _ H env). - generalize (IHt _ H0 env) ; intros. - destruct t. - red ; intro. - rewrite <- make_conj_impl in H2. - tauto. - rewrite <- make_conj_impl in H2. - tauto. - Qed. - - - Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool := - cnf_checker (xcnf true f) w. - - Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t. - Proof. - unfold tauto_checker. - intros. - change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)). - apply (xcnf_correct t true). - eapply cnf_checker_sound ; eauto. - Qed. - - - - -End S. - diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v deleted file mode 100644 index 240c0fb7..00000000 --- a/contrib/micromega/VarMap.v +++ /dev/null @@ -1,258 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import ZArith. -Require Import Coq.Arith.Max. -Require Import List. -Set Implicit Arguments. - -(* I have addded a Leaf constructor to the varmap data structure (/contrib/ring/Quote.v) - -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. - BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. -*) - -Section MakeVarMap. - Variable A : Type. - Variable default : A. - - Inductive t : Type := - | Empty : t - | Leaf : A -> t - | Node : t -> A -> t -> t . - - Fixpoint find (vm : t ) (p:positive) {struct vm} : A := - match vm with - | Empty => default - | Leaf i => i - | Node l e r => match p with - | xH => e - | xO p => find l p - | xI p => find r p - end - end. - - (* an off_map (a map with offset) offers the same functionalites as /contrib/setoid_ring/BinList.v - it is used in EnvRing.v *) -(* - Definition off_map := (option positive *t )%type. - - - - Definition jump (j:positive) (l:off_map ) := - let (o,m) := l in - match o with - | None => (Some j,m) - | Some j0 => (Some (j+j0)%positive,m) - end. - - Definition nth (n:positive) (l: off_map ) := - let (o,m) := l in - let idx := match o with - | None => n - | Some i => i + n - end%positive in - find idx m. - - - Definition hd (l:off_map) := nth xH l. - - - Definition tail (l:off_map ) := jump xH l. - - - Lemma psucc : forall p, (match p with - | xI y' => xO (Psucc y') - | xO y' => xI y' - | 1%positive => 2%positive - end) = (p+1)%positive. - Proof. - destruct p. - auto with zarith. - rewrite xI_succ_xO. - auto with zarith. - reflexivity. - Qed. - - Lemma jump_Pplus : forall i j l, - (jump (i + j) l) = (jump i (jump j l)). - Proof. - unfold jump. - destruct l. - destruct o. - rewrite Pplus_assoc. - reflexivity. - reflexivity. - Qed. - - Lemma jump_simpl : forall p l, - jump p l = - match p with - | xH => tail l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tail l)) - end. - Proof. - destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. - (* xI p = p + p + 1 *) - rewrite xI_succ_xO. - rewrite Pplus_diag. - rewrite <- Pplus_one_succ_r. - reflexivity. - (* xO p = p + p *) - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - Ltac jump_s := - repeat - match goal with - | |- context [jump xH ?e] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) - end. - - Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Psucc : forall j l, - (jump (Psucc j) l) = (jump 1 (jump j l)). - Proof. - intros. - rewrite <- jump_Pplus. - rewrite Pplus_one_succ_r. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite <- Pplus_one_succ_r. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. - Qed. - - Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l. - Proof. - intros. - jump_s. - repeat rewrite <- jump_Pplus. - reflexivity. - Qed. - - - Lemma nth_spec : forall p l, - nth p l = - match p with - | xH => hd l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - Proof. - unfold nth. - destruct l. - destruct o. - simpl. - rewrite psucc. - destruct p. - replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive. - reflexivity. - rewrite xI_succ_xO. - rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag. - rewrite Pplus_comm. - symmetry. - rewrite (Pplus_comm p0). - rewrite <- Pplus_assoc. - rewrite (Pplus_comm 1)%positive. - rewrite <- Pplus_assoc. - reflexivity. - (**) - replace ((p0 + xO p))%positive with (p + p0 + p)%positive. - reflexivity. - rewrite <- Pplus_diag. - rewrite <- Pplus_assoc. - rewrite Pplus_comm. - rewrite Pplus_assoc. - reflexivity. - reflexivity. - simpl. - destruct p. - rewrite xI_succ_xO. - rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag. - symmetry. - rewrite Pplus_comm. - rewrite Pplus_assoc. - reflexivity. - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - - Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l). - Proof. - destruct l. - unfold tail. - unfold hd. - unfold jump. - unfold nth. - destruct o. - symmetry. - rewrite Pplus_comm. - rewrite <- Pplus_assoc. - rewrite (Pplus_comm p0). - reflexivity. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). - Proof. - destruct l. - unfold tail. - unfold nth, jump. - destruct o. - rewrite ((Pplus_comm p)). - rewrite <- (Pplus_assoc p0). - rewrite Pplus_diag. - rewrite <- Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_one_succ_r. - rewrite (Pplus_comm (Pdouble_minus_one p)). - rewrite Pplus_assoc. - rewrite (Pplus_comm p0). - reflexivity. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. - Qed. - -*) - -End MakeVarMap. - diff --git a/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v deleted file mode 100644 index ced67e39..00000000 --- a/contrib/micromega/ZCoeff.v +++ /dev/null @@ -1,173 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Evgeny Makarov, INRIA, 2007 *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import ZArith. -Require Import InitialRing. -Require Import Setoid. - -Import OrderedRingSyntax. - -Set Implicit Arguments. - -Section InitialMorphism. - -Variable R : Type. -Variables rO rI : R. -Variables rplus rtimes rminus: R -> R -> R. -Variable ropp : R -> R. -Variables req rle rlt : R -> R -> Prop. - -Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt. - -Notation "0" := rO. -Notation "1" := rI. -Notation "x + y" := (rplus x y). -Notation "x * y " := (rtimes x y). -Notation "x - y " := (rminus x y). -Notation "- x" := (ropp x). -Notation "x == y" := (req x y). -Notation "x ~= y" := (~ req x y). -Notation "x <= y" := (rle x y). -Notation "x < y" := (rlt x y). - -Lemma req_refl : forall x, req x x. -Proof. - destruct sor.(SORsetoid). - apply Equivalence_Reflexive. -Qed. - -Lemma req_sym : forall x y, req x y -> req y x. -Proof. - destruct sor.(SORsetoid). - apply Equivalence_Symmetric. -Qed. - -Lemma req_trans : forall x y z, req x y -> req y z -> req x z. -Proof. - destruct sor.(SORsetoid). - apply Equivalence_Transitive. -Qed. - - -Add Relation R req - reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) - symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _) - transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _) -as sor_setoid. - -Add Morphism rplus with signature req ==> req ==> req as rplus_morph. -Proof. -exact sor.(SORplus_wd). -Qed. -Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph. -Proof. -exact sor.(SORtimes_wd). -Qed. -Add Morphism ropp with signature req ==> req as ropp_morph. -Proof. -exact sor.(SORopp_wd). -Qed. -Add Morphism rle with signature req ==> req ==> iff as rle_morph. -Proof. -exact sor.(SORle_wd). -Qed. -Add Morphism rlt with signature req ==> req ==> iff as rlt_morph. -Proof. -exact sor.(SORlt_wd). -Qed. -Add Morphism rminus with signature req ==> req ==> req as rminus_morph. -Proof. - exact (rminus_morph sor). -Qed. - -Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption. -Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption. - -Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp. - -Notation phi_pos := (gen_phiPOS 1 rplus rtimes). -Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes). - -Notation "[ x ]" := (gen_order_phi_Z x). - -Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req. -Proof. -constructor. -exact rplus_morph. -exact rtimes_morph. -exact ropp_morph. -Qed. - -Lemma Zring_morph : - ring_morph 0 1 rplus rtimes rminus ropp req - 0%Z 1%Z Zplus Zmult Zminus Zopp - Zeq_bool gen_order_phi_Z. -Proof. -exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). -Qed. - -Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. -Proof. -induction x as [x IH | x IH |]; simpl; -try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); -try apply (Rlt_0_1 sor); assumption. -Qed. - -Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x. -Proof. -exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd - (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). -Qed. - -Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. -Proof. -intros x y H. pattern y; apply Plt_ind with x. -rewrite phi_pos1_succ; apply (Rlt_succ_r sor). -clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). -assumption. -Qed. - -Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. -Proof. -unfold Zlt; intros x y H; -do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); -destruct x; destruct y; simpl in *; try discriminate. -apply phi_pos1_pos. -now apply clt_pos_morph. -apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. -apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. -apply phi_pos1_pos. -rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor). -now apply clt_pos_morph. -Qed. - -Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y]. -Proof. -unfold Zle_bool; intros x y H. -case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. -le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. -le_less. now apply clt_morph. -discriminate. -Qed. - -Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. -Proof. -intros x y H. unfold Zeq_bool in H. -case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H). -apply (Rlt_neq sor). now apply clt_morph. -fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1. -apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. -Qed. - -End InitialMorphism. - - diff --git a/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v deleted file mode 100644 index 0855925a..00000000 --- a/contrib/micromega/ZMicromega.v +++ /dev/null @@ -1,705 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -Require Import OrderedRing. -Require Import RingMicromega. -Require Import ZCoeff. -Require Import Refl. -Require Import ZArith. -Require Import List. -Require Import Bool. - -Ltac flatten_bool := - repeat match goal with - [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id - | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id - end. - -Require Import EnvRing. - -Open Scope Z_scope. - -Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt. -Proof. - constructor ; intros ; subst ; try (intuition (auto with zarith)). - apply Zsth. - apply Zth. - destruct (Ztrichotomy n m) ; intuition (auto with zarith). - apply Zmult_lt_0_compat ; auto. -Qed. - -Lemma ZSORaddon : - SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *) - 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) - Zeq_bool Zle_bool - (fun x => x) (fun x => x) (pow_N 1 Zmult). -Proof. - constructor. - constructor ; intros ; try reflexivity. - apply Zeq_bool_eq ; auto. - constructor. - reflexivity. - intros x y. - apply Zeq_bool_neq ; auto. - apply Zle_bool_imp_le. -Qed. - - -(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) - -Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z := - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2) - | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2) - | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2) - | PEopp pe1 => - (Zeval_expr env pe1) - | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n) - end. - -Lemma Zeval_expr_simpl : forall env e, - Zeval_expr env e = - match e with - | PEc c => c - | PEX j => env j - | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2) - | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2) - | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2) - | PEopp pe1 => - (Zeval_expr env pe1) - | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n) - end. -Proof. - destruct e ; reflexivity. -Qed. - - -Definition Zeval_expr' := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult). - -Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n. -Proof. - destruct n. - reflexivity. - simpl. - unfold Zpower_pos. - replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring. - generalize 1. - induction p; simpl ; intros ; repeat rewrite IHp ; ring. -Qed. - - - -Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = Zeval_expr' env e. -Proof. - induction e ; simpl ; subst ; try congruence. - rewrite IHe. - apply ZNpower. -Qed. - -Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := -match o with -| OpEq => @eq Z -| OpNEq => fun x y => ~ x = y -| OpLe => Zle -| OpGe => Zge -| OpLt => Zlt -| OpGt => Zgt -end. - -Definition Zeval_formula (e: PolEnv Z) (ff : Formula Z) := - let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e rhs). - -Definition Zeval_formula' := - eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). - -Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. -Proof. - intros. - unfold Zeval_formula. - destruct f. - repeat rewrite Zeval_expr_compat. - unfold Zeval_formula'. - unfold Zeval_expr'. - split ; destruct Fop ; simpl; auto with zarith. -Qed. - - - -Definition Zeval_nformula := - eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). - -Definition Zeval_op1 (o : Op1) : Z -> Prop := -match o with -| Equal => fun x : Z => x = 0 -| NonEqual => fun x : Z => x <> 0 -| Strict => fun x : Z => 0 < x -| NonStrict => fun x : Z => 0 <= x -end. - -Lemma Zeval_nformula_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)). -Proof. - intros. - destruct f. - rewrite Zeval_expr_compat. - reflexivity. -Qed. - -Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d). -Proof. - exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d). -Qed. - -Definition ZWitness := ConeMember Z. - -Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool. - -Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), - ZWeakChecker l cm = true -> - forall env, make_impl (Zeval_nformula env) l False. -Proof. - intros l cm H. - intro. - unfold Zeval_nformula. - apply (checker_nf_sound Zsor ZSORaddon l cm). - unfold ZWeakChecker in H. - exact H. -Qed. - -Definition xnormalise (t:Formula Z) : list (NFormula Z) := - let (lhs,o,rhs) := t in - match o with - | OpEq => - ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil - | OpNEq => (PEsub lhs rhs,Equal) :: nil - | OpGt => (PEsub rhs lhs,NonStrict) :: nil - | OpLt => (PEsub lhs rhs,NonStrict) :: nil - | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil - | OpLe => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil - end. - -Require Import Tauto. - -Definition normalise (t:Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnormalise t). - - -Lemma normalise_correct : forall env t, eval_cnf (Zeval_nformula env) (normalise t) <-> Zeval_formula env t. -Proof. - unfold normalise, xnormalise ; simpl ; intros env t. - rewrite Zeval_formula_compat. - unfold eval_cnf. - destruct t as [lhs o rhs]; case_eq o ; simpl; - generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; - intuition (auto with zarith). -Qed. - -Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := - let (lhs,o,rhs) := t in - match o with - | OpEq => (PEsub lhs rhs,Equal) :: nil - | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil - | OpGt => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil - | OpLt => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil - | OpGe => (PEsub lhs rhs,NonStrict) :: nil - | OpLe => (PEsub rhs lhs,NonStrict) :: nil - end. - -Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := - List.map (fun x => x::nil) (xnegate t). - -Lemma negate_correct : forall env t, eval_cnf (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t. -Proof. - unfold negate, xnegate ; simpl ; intros env t. - rewrite Zeval_formula_compat. - unfold eval_cnf. - destruct t as [lhs o rhs]; case_eq o ; simpl ; - generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; - intuition (auto with zarith). -Qed. - - -Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w. - -(* To get a complete checker, the proof format has to be enriched *) - -Require Import Zdiv. -Open Scope Z_scope. - -Definition ceiling (a b:Z) : Z := - let (q,r) := Zdiv_eucl a b in - match r with - | Z0 => q - | _ => q + 1 - end. - -Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a. -Proof. - unfold ceiling. - intros. - generalize (Z_div_mod b a H). - destruct (Zdiv_eucl b a). - intros. - destruct H1. - destruct H2. - subst. - destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate. - assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith). - destruct HH ;auto. - generalize (Zmult_lt_compat_l _ _ _ H3 H1). - auto with zarith. - clear H2. - assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). - destruct HH ;auto. - assert (0 < a) by auto with zarith. - generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1). - intros. - rewrite Zmult_comm in H4. - rewrite (Zmult_comm z) in H4. - auto with zarith. -Qed. - -Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x <= b -> x <= Zdiv b a. -Proof. - unfold Zdiv. - intros. - generalize (Z_div_mod b a H). - destruct (Zdiv_eucl b a). - intros. - destruct H1. - destruct H2. - subst. - assert (HH :x <= z \/ z <= x -1) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). - destruct HH ;auto. - assert (0 < a) by auto with zarith. - generalize (Zmult_lt_0_le_compat_r _ _ _ H4 H1). - intros. - ring_simplify in H5. - rewrite Zmult_comm in H5. - auto with zarith. -Qed. - - -(* In this case, a certificate is made of a pair of inequations, in 1 variable, - that do not have an integer solution. - => modify the fourier elimination - *) -Require Import QArith. - - -Inductive ProofTerm : Type := -| RatProof : ZWitness -> ProofTerm -| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm -| EnumProof : Q -> PExprC Z -> Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm. - -(* n/d <= x -> d*x - n >= 0 *) - -Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z := - let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict). - -(* x <= n/d -> d * x <= d *) -Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z := - let (n,d) := q in - (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict). - -Definition qceiling (q:Q) : Z := - let (n,d) := q in ceiling n (Zpos d). - -Definition qfloor (q:Q) : Z := - let (n,d) := q in Zdiv n (Zpos d). - -Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := - (PEsub v (PEc (qceiling q)), NonStrict). - -Definition neg_nformula (f : NFormula Z) := - let (e,o) := f in - (PEopp (PEadd e (PEc 1%Z)), o). - -Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f). -Proof. - unfold neg_nformula. - destruct f. - simpl. - intros ; subst ; simpl in *. - split; auto with zarith. -Qed. - - -Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) := - let (lb,lc) := (makeLb e lb,makeLbCut e lb) in - if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None. - - -Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm) {struct pf} : bool := - match pf with - | RatProof pf => ZWeakChecker l pf - | CutProof e q pf rst => - match cutChecker l e q pf with - | None => false - | Some c => ZChecker (c::l) rst - end - | EnumProof lb e ub pf1 pf2 rst => - match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with - | None , _ | _ , None => false - | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in - (fix label (pfs:list ProofTerm) := - fun lb ub => - match pfs with - | nil => if Z_gt_dec lb ub then true else false - | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) - end) - rst lb' ub' - end - end. - - -Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)), - ZChecker l pf = - match pf with - | RatProof pf => ZWeakChecker l pf - | CutProof e q pf rst => - match cutChecker l e q pf with - | None => false - | Some c => ZChecker (c::l) rst - end - | EnumProof lb e ub pf1 pf2 rst => - match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with - | None , _ | _ , None => false - | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in - (fix label (pfs:list ProofTerm) := - fun lb ub => - match pfs with - | nil => if Z_gt_dec lb ub then true else false - | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) - end) - rst lb' ub' - end - end. -Proof. - destruct pf ; reflexivity. -Qed. - -(* -Fixpoint depth (n:nat) : ProofTerm -> option nat := - match n with - | O => fun pf => None - | S n => - fun pf => - match pf with - | RatProof _ => Some O - | CutProof _ _ _ p => option_map S (depth n p) - | EnumProof _ _ _ _ _ l => - let f := fun pf x => - match x , depth n pf with - | None , _ | _ , None => None - | Some n1 , Some n2 => Some (Max.max n1 n2) - end in - List.fold_right f (Some O) l - end - end. -*) -Fixpoint bdepth (pf : ProofTerm) : nat := - match pf with - | RatProof _ => O - | CutProof _ _ _ p => S (bdepth p) - | EnumProof _ _ _ _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) - end. - -Require Import Wf_nat. - -Lemma in_bdepth : forall l a b p c c0 y, In y l -> ltof ProofTerm bdepth y (EnumProof a b p c c0 l). -Proof. - induction l. - simpl. - tauto. - simpl. - intros. - destruct H. - subst. - unfold ltof. - simpl. - generalize ( (fold_right - (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). - intros. - generalize (bdepth y) ; intros. - generalize (Max.max_l n0 n) (Max.max_r n0 n). - omega. - generalize (IHl a0 b p c c0 y H). - unfold ltof. - simpl. - generalize ( (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat - l)). - intros. - generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). - omega. -Qed. - -Lemma lb_lbcut : forall env e q, Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q). -Proof. - unfold makeLb, makeLbCut. - destruct q. - rewrite Zeval_nformula_simpl. - rewrite Zeval_nformula_simpl. - unfold Zeval_op1. - rewrite Zeval_expr_simpl. - rewrite Zeval_expr_simpl. - rewrite Zeval_expr_simpl. - intro. - rewrite Zeval_expr_simpl. - revert H. - generalize (Zeval_expr env e). - rewrite Zeval_expr_simpl. - rewrite Zeval_expr_simpl. - unfold qceiling. - intros. - assert ( z >= ceiling Qnum (' Qden))%Z. - apply narrow_interval_lower_bound. - compute. - reflexivity. - destruct z ; auto with zarith. - auto with zarith. -Qed. - -Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res -> - forall env, make_impl (Zeval_nformula env) l (Zeval_nformula env res). -Proof. - unfold cutChecker. - intros. - revert H. - case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate]. - generalize (ZWeakChecker_sound _ _ H env). - intros. - inversion H0 ; subst ; clear H0. - apply -> make_conj_impl. - simpl in H1. - rewrite <- make_conj_impl in H1. - intros. - apply -> neg_nformula_sound ; auto. - red ; intros. - apply H1 ; auto. - clear H H1 H0. - generalize (lb_lbcut env e lb). - intros. - destruct (Zeval_nformula_dec env ((neg_nformula (makeLb e lb)))). - auto. - rewrite -> neg_nformula_sound in H0. - assert (HH := H H0). - rewrite <- neg_nformula_sound in HH. - tauto. - reflexivity. - unfold makeLb. - destruct lb. - reflexivity. -Qed. - - -Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res -> - forall env, make_conj (Zeval_nformula env) l -> (Zeval_expr env e >= qceiling lb)%Z. -Proof. - intros. - generalize (cutChecker_sound _ _ _ _ _ H env). - intros. - rewrite <- (make_conj_impl) in H1. - generalize (H1 H0). - unfold cutChecker in H. - destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf). - unfold makeLbCut in H. - inversion H ; subst. - clear H. - simpl. - rewrite Zeval_expr_compat. - unfold Zeval_expr'. - auto with zarith. - discriminate. -Qed. - - -Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (Zeval_nformula env) l False. -Proof. - induction w using (well_founded_ind (well_founded_ltof _ bdepth)). - destruct w. - (* RatProof *) - simpl. - intros. - eapply ZWeakChecker_sound. - apply H0. - (* CutProof *) - simpl. - intro. - case_eq (cutChecker l p q z) ; intros. - generalize (cutChecker_sound _ _ _ _ _ H0 env). - intro. - assert (make_impl (Zeval_nformula env) (n::l) False). - eapply (H w) ; auto. - unfold ltof. - simpl. - auto with arith. - simpl in H3. - rewrite <- make_conj_impl in H2. - rewrite <- make_conj_impl in H3. - rewrite <- make_conj_impl. - tauto. - discriminate. - (* EnumProof *) - intro. - rewrite ZChecker_simpl. - case_eq (cutChecker l0 p q z). - rename q into llb. - case_eq (cutChecker l0 (PEopp p) (- q0) z0). - intros. - rename q0 into uub. - (* get the bounds of the enum *) - rewrite <- make_conj_impl. - intro. - assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z. - generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3). - generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3). - intros. - rewrite Zeval_expr_simpl in H5. - auto with zarith. - clear H0 H1. - revert H2 H3 H4. - generalize (qceiling llb) (- qceiling (- uub))%Z. - set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool := - match pfs with - | nil => if Z_gt_dec lb ub then true else false - | pf :: rsr => - (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf && - label rsr (lb + 1)%Z ub)%bool - end)). - intros z1 z2. - intros. - assert (forall x, z1 <= x <= z2 -> exists pr, - (In pr l /\ - ZChecker ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z. - clear H. - revert H2. - clear H4. - revert z1 z2. - induction l;simpl ;intros. - destruct (Z_gt_dec z1 z2). - intros. - apply False_ind ; omega. - discriminate. - intros. - simpl in H2. - flatten_bool. - assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. - destruct HH. - subst. - exists a ; auto. - assert (z1 + 1 <= x <= z2)%Z by omega. - destruct (IHl _ _ H1 _ H4). - destruct H5. - exists x0 ; split;auto. - (*/asser *) - destruct (H0 _ H4) as [pr [Hin Hcheker]]. - assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False). - apply (H pr);auto. - apply in_bdepth ; auto. - rewrite <- make_conj_impl in H1. - apply H1. - rewrite make_conj_cons. - split ;auto. - rewrite Zeval_nformula_simpl; - unfold Zeval_op1; - rewrite Zeval_expr_simpl. - generalize (Zeval_expr env p). - intros. - rewrite Zeval_expr_simpl. - auto with zarith. - intros ; discriminate. - intros ; discriminate. -Qed. - -Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ProofTerm): bool := - @tauto_checker (Formula Z) (NFormula Z) normalise negate ProofTerm ZChecker f w. - -Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. -Proof. - intros f w. - unfold ZTautoChecker. - apply (tauto_checker_sound Zeval_formula Zeval_nformula). - apply Zeval_nformula_dec. - intros env t. - rewrite normalise_correct ; auto. - intros env t. - rewrite negate_correct ; auto. - intros t w0. - apply ZChecker_sound. -Qed. - - -Open Scope Z_scope. - - -Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness := - match e with - | S_In n => S_In _ (f n) - | S_Ideal e cm => S_Ideal e (map_cone f cm) - | S_Square _ => e - | S_Monoid l => S_Monoid _ (List.map f l) - | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2) - | S_Add cm1 cm2 => S_Add (map_cone f cm1) (map_cone f cm2) - | _ => e - end. - -Fixpoint indexes (e:ZWitness) : list nat := - match e with - | S_In n => n::nil - | S_Ideal e cm => indexes cm - | S_Square e => nil - | S_Monoid l => l - | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2) - | S_Add cm1 cm2 => (indexes cm1)++ (indexes cm2) - | _ => nil - end. - -(** To ease bindings from ml code **) -(*Definition varmap := Quote.varmap.*) -Definition make_impl := Refl.make_impl. -Definition make_conj := Refl.make_conj. - -Require VarMap. - -(*Definition varmap_type := VarMap.t Z. *) -Definition env := PolEnv Z. -Definition node := @VarMap.Node Z. -Definition empty := @VarMap.Empty Z. -Definition leaf := @VarMap.Leaf Z. - -Definition coneMember := ZWitness. - -Definition eval := Zeval_formula. - -Definition prod_pos_nat := prod positive nat. - -Require Import Int. - - -Definition n_of_Z (z:Z) : BinNat.N := - match z with - | Z0 => N0 - | Zpos p => Npos p - | Zneg p => N0 - end. - - - diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml deleted file mode 100644 index f4efcd08..00000000 --- a/contrib/micromega/certificate.ml +++ /dev/null @@ -1,740 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -(* We take as input a list of polynomials [p1...pn] and return an unfeasibility - certificate polynomial. *) - -(*open Micromega.Polynomial*) -open Big_int -open Num - -module Mc = Micromega -module Ml2C = Mutils.CamlToCoq -module C2Ml = Mutils.CoqToCaml - -let (<+>) = add_num -let (<->) = minus_num -let (<*>) = mult_num - -type var = Mc.positive - -module Monomial : -sig - type t - val const : t - val var : var -> t - val find : var -> t -> int - val mult : var -> t -> t - val prod : t -> t -> t - val compare : t -> t -> int - val pp : out_channel -> t -> unit - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a -end - = -struct - (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) - open Map - - type t = int Map.t - - (* The monomial that corresponds to a constant *) - let const = Map.empty - - (* The monomial 'x' *) - let var x = Map.add x 1 Map.empty - - (* Get the degre of a variable in a monomial *) - let find x m = try find x m with Not_found -> 0 - - (* Multiply a monomial by a variable *) - let mult x m = add x ( (find x m) + 1) m - - (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - - (* Total ordering of monomials *) - let compare m1 m2 = Map.compare Pervasives.compare m1 m2 - - let pp o m = Map.iter (fun k v -> - if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k) - else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m - - let fold = fold - -end - - -module Poly : - (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation - (expected to be fast enough - Coq is probably the bottleneck) - *The new ring contribution is using a sparse Horner representation. - *) -sig - type t - val get : Monomial.t -> t -> num - val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t - val mult : Monomial.t -> num -> t -> t - val product : t -> t -> t - val addition : t -> t -> t - val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val pp : out_channel -> t -> unit - val compare : t -> t -> int -end = -struct - (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) - open P - - type t = num P.t - - let pp o p = P.iter (fun k v -> - if compare_num v (Int 0) <> 0 - then - if Monomial.compare Monomial.const k = 0 - then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p - - (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - - - (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty - - (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty - - (* The addition of a monomial *) - - let add : Monomial.t -> num -> t -> t = - fun mn v p -> - let vl = (get mn p) <+> v in - add mn vl p - - - (** Design choice: empty is not a polynomial - I do not remember why .... - **) - - (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - - - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - - - let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - - - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p - - let fold = P.fold - - let compare = compare compare_num -end - -open Mutils -type 'a number_spec = { - bigint_to_number : big_int -> 'a; - number_to_num : 'a -> num; - zero : 'a; - unit : 'a; - mult : 'a -> 'a -> 'a; - eqb : 'a -> 'a -> Mc.bool -} - -let z_spec = { - bigint_to_number = Ml2C.bigint ; - number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); - zero = Mc.Z0; - unit = Mc.Zpos Mc.XH; - mult = Mc.zmult; - eqb = Mc.zeq_bool -} - - -let q_spec = { - bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); - number_to_num = C2Ml.q_to_num; - zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; - unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; - mult = Mc.qmult; - eqb = Mc.qeq_bool -} - -let r_spec = z_spec - - - - -let dev_form n_spec p = - let rec dev_form p = - match p with - | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) - | Mc.PEX v -> Poly.variable v - | Mc.PEmul(p1,p2) -> - let p1 = dev_form p1 in - let p2 = dev_form p2 in - Poly.product p1 p2 - | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) - | Mc.PEopp p -> Poly.uminus (dev_form p) - | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) - | Mc.PEpow(p,n) -> - let p = dev_form p in - let n = C2Ml.n n in - let rec pow n = - if n = 0 - then Poly.constant (n_spec.number_to_num n_spec.unit) - else Poly.product p (pow (n-1)) in - pow n in - dev_form p - - -let monomial_to_polynomial mn = - Monomial.fold - (fun v i acc -> - let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in - if acc = Mc.PEc (Mc.Zpos Mc.XH) - then mn - else Mc.PEmul(mn,acc)) - mn - (Mc.PEc (Mc.Zpos Mc.XH)) - -let list_to_polynomial vars l = - assert (List.for_all (fun x -> ceiling_num x =/ x) l); - let var x = monomial_to_polynomial (List.nth vars x) in - let rec xtopoly p i = function - | [] -> p - | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l - else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = - if c = Mc.PEc (Mc.Zpos Mc.XH) - then var i - else Mc.PEmul (c,var i) in - let p' = if p = Mc.PEc Mc.Z0 then mn else - Mc.PEadd (mn, p) in - xtopoly p' (i+1) l in - - xtopoly (Mc.PEc Mc.Z0) 0 l - -let rec fixpoint f x = - let y' = f x in - if y' = x then y' - else fixpoint f y' - - - - - - - - -let rec_simpl_cone n_spec e = - let simpl_cone = - Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in - - let rec rec_simpl_cone = function - | Mc.S_Mult(t1, t2) -> - simpl_cone (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.S_Add(t1,t2) -> - simpl_cone (Mc.S_Add (rec_simpl_cone t1, rec_simpl_cone t2)) - | x -> simpl_cone x in - rec_simpl_cone e - - -let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone - | Ideal of cone *cone - | Mult of cone * cone - | Other of cone -and cone = Mc.zWitness - - - -let factorise_linear_cone c = - - let rec cone_list c l = - match c with - | Mc.S_Add (x,r) -> cone_list r (x::l) - | _ -> c :: l in - - let factorise c1 c2 = - match c1 , c2 with - | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') -> - if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None - | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') -> - if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None - | _ -> None in - - let rec rebuild_cone l pending = - match l with - | [] -> (match pending with - | None -> Mc.S_Z - | Some p -> p - ) - | e::l -> - (match pending with - | None -> rebuild_cone l (Some e) - | Some p -> (match factorise p e with - | None -> Mc.S_Add(p, rebuild_cone l (Some e)) - | Some f -> rebuild_cone l (Some f) ) - ) in - - (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) - - - -(* The binding with Fourier might be a bit obsolete - -- how does it handle equalities ? *) - -(* Certificates are elements of the cone such that P = 0 *) - -(* To begin with, we search for certificates of the form: - a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 - where pi >= 0 qi > 0 - ai >= 0 - bi >= 0 - Sum bi + c >= 1 - This is a linear problem: each monomial is considered as a variable. - Hence, we can use fourier. - - The variable c is at index 0 -*) - -open Mfourier - (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*) - (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*) -module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*) - -module Vect = Fourier.Vect -open Fourier.Cstr - -(* fold_left followed by a rev ! *) - -let constrain_monomial mn l = - let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if mn = Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; - op = Eq ; - cst = Big_int zero_big_int } - else - { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; - op = Eq ; - cst = Big_int zero_big_int } - - -let positivity l = - let rec xpositivity i l = - match l with - | [] -> [] - | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; - cst = Int 0 } :: (xpositivity (i+1) l) - in - xpositivity 0 l - - -let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" - | Mc.Equal -> "= 0" - | Mc.NonEqual -> "<> 0" - - - -(* If the certificate includes at least one strict inequality, - the obtained polynomial can also be 0 *) -let build_linear_system l = - - (* Gather the monomials: HINT add up of the polynomials *) - let l' = List.map fst l in - let monomials = - List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' - in (* For each monomial, compute a constraint *) - let s0 = - Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in - (* I need at least something strictly positive *) - let strict = { - coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int - | _ -> Big_int zero_big_int) l)); - op = Ge ; cst = Big_int unit_big_int } in - (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int unit_big_int]) ; - op = Ge ; - cst = Big_int zero_big_int}::(strict::(positivity l)@s0) - - -let big_int_to_z = Ml2C.bigint - -(* For Q, this is a pity that the certificate has been scaled - -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec cert li = - let bint_to_cst = n_spec.bigint_to_number in - match cert with - | [] -> None - | e::cert' -> - let cst = match compare_big_int e zero_big_int with - | 0 -> Mc.S_Z - | 1 -> Mc.S_Pos (bint_to_cst e) - | _ -> failwith "positivity error" - in - let rec scalar_product cert l = - match cert with - | [] -> Mc.S_Z - | c::cert -> match l with - | [] -> failwith "make_certificate(1)" - | i::l -> - let r = scalar_product cert l in - match compare_big_int c zero_big_int with - | -1 -> Mc.S_Add ( - Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)), - r) - | 0 -> r - | _ -> Mc.S_Add ( - Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)), - r) in - - Some ((factorise_linear_cone - (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li))))) - - -exception Found of Monomial.t - -let raw_certificate l = - let sys = build_linear_system l in - try - match Fourier.find_point sys with - | None -> None - | Some cert -> Some (rats_to_ints (Vect.to_list cert)) - (* should not use rats_to_ints *) - with x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); - flush stdout) ; - None - - -let simple_linear_prover to_constant l = - let (lc,li) = List.split l in - match raw_certificate lc with - | None -> None (* No certificate *) - | Some cert -> make_certificate to_constant cert li - - - -let linear_prover n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in - let (l1,l') = List.partition - (fun (x,_) -> if snd' x = Mc.NonEqual then true else false) li in - let l' = List.map - (fun (c,i) -> let (Mc.Pair(x,y)) = c in - match y with - Mc.NonEqual -> failwith "cannot happen" - | y -> ((dev_form n_spec x, y),i)) l' in - - simple_linear_prover n_spec l' - - -let linear_prover n_spec l = - try linear_prover n_spec l with - x -> (print_string (Printexc.to_string x); None) - -(* zprover.... *) - -(* I need to gather the set of variables ---> - Then go for fold - Once I have an interval, I need a certificate : 2 other fourier elims. - (I could probably get the certificate directly - as it is done in the fourier contrib.) -*) - -let make_linear_system l = - let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) - (Poly.constant (Int 0)) l' in - let monomials = Poly.fold - (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in - (List.map (fun (c,op) -> - {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; - op = op ; - cst = minus_num ( (Poly.get Monomial.const c))}) l - ,monomials) - - -open Interval -let pplus x y = Mc.PEadd(x,y) -let pmult x y = Mc.PEmul(x,y) -let pconst x = Mc.PEc x -let popp x = Mc.PEopp x - -let debug = false - -(* keep track of enumerated vectors *) -let rec mem p x l = - match l with [] -> false | e::l -> if p x e then true else mem p x l - -let rec remove_assoc p x l = - match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) - -let eq x y = Vect.compare x y = 0 - -let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l - - -(* The prover is (probably) incomplete -- - only searching for naive cutting planes *) - -let candidates sys = - let ll = List.fold_right ( - fun (Mc.Pair(e,k)) r -> - match k with - | Mc.NonStrict -> (dev_form z_spec e , Ge)::r - | Mc.Equal -> (dev_form z_spec e , Eq)::r - (* we already know the bound -- don't compute it again *) - | _ -> failwith "Cannot happen candidates") sys [] in - - let (sys,var_mn) = make_linear_system ll in - let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in - (List.fold_left (fun l cstr -> - let gcd = Big_int (Vect.gcd cstr.coeffs) in - if gcd =/ (Int 1) && cstr.op = Eq - then l - else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars - - -let rec xzlinear_prover planes sys = - match linear_prover z_spec sys with - | Some prf -> Some (Mc.RatProof prf) - | None -> (* find the candidate with the smallest range *) - (* Grrr - linear_prover is also calling 'make_linear_system' *) - let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with - Mc.NonEqual -> r - | k -> (dev_form z_spec e , - match k with - Mc.NonStrict -> Ge - | Mc.Equal -> Eq - | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in - let (ll,var) = make_linear_system ll in - let candidates = List.fold_left (fun acc vect -> - match Fourier.optimise vect ll with - | None -> acc - | Some i -> -(* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) - flush stdout ; - (vect,i) ::acc) [] planes in - - let smallest_interval = - match List.fold_left (fun (x1,i1) (x2,i2) -> - if smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates - with - | (x,Itv(Some i, Some j)) -> Some(i,x,j) - | (x,Point n) -> Some(n,x,n) - | x -> None (* This might be a cutting plane *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = - (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), - Ml2C.bigint (denominator lb)) in - let (ubn,ubd) = - (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , - Ml2C.bigint (denominator ub)) in - let expr = list_to_polynomial var (Vect.to_list e) in - (match - (*x <= ub -> x > ub *) - linear_prover z_spec - (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), - Mc.NonStrict) :: sys), - (* lb <= x -> lb > x *) - linear_prover z_spec - (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) , - Mc.NonStrict)::sys) - with - | Some cub , Some clb -> - (match zlinear_enum (remove e planes) expr - (ceiling_num lb) (floor_num ub) sys - with - | None -> None - | Some prf -> - Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf))) - | _ -> None - ) - | _ -> None -and zlinear_enum planes expr clb cub l = - if clb >/ cub - then Some Mc.Nil - else - let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in - let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in - (*let enum = *) - match xzlinear_prover planes sys' with - | None -> if debug then print_string "zlp?"; None - | Some prf -> if debug then print_string "zlp!"; - match zlinear_enum planes expr (clb +/ (Int 1)) cub l with - | None -> None - | Some prfl -> Some (Mc.Cons(prf,prfl)) - -let zlinear_prover sys = - let candidates = candidates sys in - (* Printf.printf "candidates %d" (List.length candidates) ; *) - xzlinear_prover candidates sys - -open Sos - -let rec scale_term t = - match t with - | Zero -> unit_big_int , Zero - | Const n -> (denominator n) , Const (Big_int (numerator n)) - | Var n -> unit_big_int , Var n - | Inv _ -> failwith "scale_term : not implemented" - | Opp t -> let s, t = scale_term t in s, Opp t - | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - let e = mult_big_int g (mult_big_int s1' s2') in - if (compare_big_int e unit_big_int) = 0 - then (unit_big_int, Add (y1,y2)) - else e, Add (Mul(Const (Big_int s2'), y1), - Mul (Const (Big_int s1'), y2)) - | Sub _ -> failwith "scale term: not implemented" - | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in - mult_big_int s1 s2 , Mul (y1, y2) - | Pow(t,n) -> let s,t = scale_term t in - power_big_int_positive_int s n , Pow(t,n) - | _ -> failwith "scale_term : not implemented" - -let scale_term t = - let (s,t') = scale_term t in - s,t' - - -let get_index_of_ith_match f i l = - let rec get j res l = - match l with - | [] -> failwith "bad index" - | e::l -> if f e - then - (if j = i then res else get (j+1) (res+1) l ) - else get j (res+1) l in - get 0 0 l - - -let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) - - -open Micromega - let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - | _ -> failwith "term_to_q_expr: not implemented" - -let q_cert_of_pos pos = - let rec _cert_of_pos = function - Axiom_eq i -> Mc.S_In (Ml2C.nat i) - | Axiom_le i -> Mc.S_In (Ml2C.nat i) - | Axiom_lt i -> Mc.S_In (Ml2C.nat i) - | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l) - | Rational_eq n | Rational_le n | Rational_lt n -> - if compare_num n (Int 0) = 0 then Mc.S_Z else - Mc.S_Pos (Ml2C.q n) - | Square t -> Mc.S_Square (term_to_q_expr t) - | Eqmul (t, y) -> Mc.S_Ideal(term_to_q_expr t, _cert_of_pos y) - | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in - simplify_cone q_spec (_cert_of_pos pos) - - - let rec term_to_z_expr = function - | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) - | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) - | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) - | Opp p -> PEopp (term_to_z_expr p) - | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) - | _ -> failwith "term_to_z_expr: not implemented" - -let z_cert_of_pos pos = - let s,pos = (scale_certificate pos) in - let rec _cert_of_pos = function - Axiom_eq i -> Mc.S_In (Ml2C.nat i) - | Axiom_le i -> Mc.S_In (Ml2C.nat i) - | Axiom_lt i -> Mc.S_In (Ml2C.nat i) - | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l) - | Rational_eq n | Rational_le n | Rational_lt n -> - if compare_num n (Int 0) = 0 then Mc.S_Z else - Mc.S_Pos (Ml2C.bigint (big_int_of_num n)) - | Square t -> Mc.S_Square (term_to_z_expr t) - | Eqmul (t, y) -> Mc.S_Ideal(term_to_z_expr t, _cert_of_pos y) - | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in - simplify_cone z_spec (_cert_of_pos pos) - diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml deleted file mode 100644 index b4863ffc..00000000 --- a/contrib/micromega/coq_micromega.ml +++ /dev/null @@ -1,1286 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -open Mutils -let debug = false - -let time str f x = - let t0 = (Unix.times()).Unix.tms_utime in - let res = f x in - let t1 = (Unix.times()).Unix.tms_utime in - (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; - flush stdout); - res - -type ('a,'b) formula = - | TT - | FF - | X of 'b - | A of 'a * Names.name - | C of ('a,'b) formula * ('a,'b) formula * Names.name - | D of ('a,'b) formula * ('a,'b) formula * Names.name - | N of ('a,'b) formula * Names.name - | I of ('a,'b) formula * ('a,'b) formula * Names.name - -let none = Names.Anonymous - -let tag_formula t f = - match f with - | A(x,_) -> A(x,t) - | C(x,y,_) -> C(x,y,t) - | D(x,y,_) -> D(x,y,t) - | N(x,_) -> N(x,t) - | I(x,y,_) -> I(x,y,t) - | _ -> f - -let tt = [] -let ff = [ [] ] - - -type ('constant,'contr) sentence = - ('constant Micromega.formula, 'contr) formula - -let cnf negate normalise f = - let negate a = - CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in - - let normalise a = - CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (normalise a) in - - let and_cnf x y = x @ y in - let or_clause_cnf t f = List.map (fun x -> t@x ) f in - - let rec or_cnf f f' = - match f with - | [] -> tt - | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in - - let rec xcnf (pol : bool) f = - match f with - | TT -> if pol then tt else ff (* ?? *) - | FF -> if pol then ff else tt (* ?? *) - | X p -> if pol then ff else ff (* ?? *) - | A(x,t) -> if pol then normalise x else negate x - | N(e,t) -> xcnf (not pol) e - | C(e1,e2,t) -> - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D(e1,e2,t) -> - (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I(e1,e2,t) -> - (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in - - xcnf true f - - - -module M = -struct - open Coqlib - open Term - (* let constant = gen_constant_in_modules "Omicron" coq_modules*) - - - let logic_dir = ["Coq";"Logic";"Decidable"] - let coq_modules = - init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ - [ ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; - ["Coq"; "micromega"; "ZMicromega"]; - ["Coq" ; "micromega" ; "Tauto"]; - ["Coq" ; "micromega" ; "RingMicromega"]; - ["Coq" ; "micromega" ; "EnvRing"]; - ["Coq";"QArith"; "QArith_base"]; - ["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["LRing_normalise"]] - - let constant = gen_constant_in_modules "ZMicromega" coq_modules - - let coq_and = lazy (constant "and") - let coq_or = lazy (constant "or") - let coq_not = lazy (constant "not") - let coq_iff = lazy (constant "iff") - let coq_True = lazy (constant "True") - let coq_False = lazy (constant "False") - - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - - let coq_O = lazy (constant "O") - let coq_S = lazy (constant "S") - let coq_nat = lazy (constant "nat") - - let coq_NO = lazy - (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") - let coq_Npos = lazy - (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") - (* let coq_n = lazy (constant "N")*) - - let coq_pair = lazy (constant "pair") - let coq_None = lazy (constant "None") - let coq_option = lazy (constant "option") - let coq_positive = lazy (constant "positive") - let coq_xH = lazy (constant "xH") - let coq_xO = lazy (constant "xO") - let coq_xI = lazy (constant "xI") - - let coq_N0 = lazy (constant "N0") - let coq_N0 = lazy (constant "Npos") - - - let coq_Z = lazy (constant "Z") - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - - let coq_ZERO = lazy (constant "Z0") - let coq_POS = lazy (constant "Zpos") - let coq_NEG = lazy (constant "Zneg") - - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") - - - let coq_Build_Witness = lazy (constant "Build_Witness") - - - let coq_Qmake = lazy (constant "Qmake") - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - - - let coq_proofTerm = lazy (constant "ProofTerm") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - - let coq_Zgt = lazy (constant "Zgt") - let coq_Zge = lazy (constant "Zge") - let coq_Zle = lazy (constant "Zle") - let coq_Zlt = lazy (constant "Zlt") - let coq_Eq = lazy (constant "eq") - - let coq_Zplus = lazy (constant "Zplus") - let coq_Zminus = lazy (constant "Zminus") - let coq_Zopp = lazy (constant "Zopp") - let coq_Zmult = lazy (constant "Zmult") - let coq_Zpower = lazy (constant "Zpower") - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" - [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") - - let coq_Qgt = lazy (constant "Qgt") - let coq_Qge = lazy (constant "Qge") - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - - - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - - - let coq_Rgt = lazy (constant "Rgt") - let coq_Rge = lazy (constant "Rge") - let coq_Rle = lazy (constant "Rle") - let coq_Rlt = lazy (constant "Rlt") - - let coq_Rplus = lazy (constant "Rplus") - let coq_Rminus = lazy (constant "Rminus") - let coq_Ropp = lazy (constant "Ropp") - let coq_Rmult = lazy (constant "Rmult") - let coq_Rpower = lazy (constant "pow") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - - - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - - - let coq_S_In = lazy (constant "S_In") - let coq_S_Square = lazy (constant "S_Square") - let coq_S_Monoid = lazy (constant "S_Monoid") - let coq_S_Ideal = lazy (constant "S_Ideal") - let coq_S_Mult = lazy (constant "S_Mult") - let coq_S_Add = lazy (constant "S_Add") - let coq_S_Pos = lazy (constant "S_Pos") - let coq_S_Z = lazy (constant "S_Z") - let coq_coneMember = lazy (constant "coneMember") - - - let coq_make_impl = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") - - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] - "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") - - - type parse_error = - | Ukn - | BadStr of string - | BadNum of int - | BadTerm of Term.constr - | Msg of string - | Goal of (Term.constr list ) * Term.constr * parse_error - - let string_of_error = function - | Ukn -> "ukn" - | BadStr s -> s - | BadNum i -> string_of_int i - | BadTerm _ -> "BadTerm" - | Msg s -> s - | Goal _ -> "Goal" - - - exception ParseError - - - - - let get_left_construct term = - match Term.kind_of_term term with - | Term.Construct(_,i) -> (i,[| |]) - | Term.App(l,rst) -> - (match Term.kind_of_term l with - | Term.Construct(_,i) -> (i,rst) - | _ -> raise ParseError - ) - | _ -> raise ParseError - - module Mc = Micromega - - let rec parse_nat term = - let (i,c) = get_left_construct term in - match i with - | 1 -> Mc.O - | 2 -> Mc.S (parse_nat (c.(0))) - | i -> raise ParseError - - - let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) - - - let rec dump_nat x = - match x with - | Mc.O -> Lazy.force coq_O - | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) - - - let rec parse_positive term = - let (i,c) = get_left_construct term in - match i with - | 1 -> Mc.XI (parse_positive c.(0)) - | 2 -> Mc.XO (parse_positive c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError - - - let rec dump_positive x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) - | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) - - let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - - - let rec dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_N0 - | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - - let rec dump_index x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) - | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) - - - let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - - let rec dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_NO - | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |]) - - let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) - - let dump_pair t1 t2 dump_t1 dump_t2 (Mc.Pair (x,y)) = - Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - - - let rec parse_z term = - let (i,c) = get_left_construct term in - match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive c.(0)) - | 3 -> Mc.Zneg (parse_positive c.(0)) - | i -> raise ParseError - - let dump_z x = - match x with - | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) - - let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x) - -let dump_num bd1 = - Term.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; - dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) - - -let dump_q q = - Term.mkApp(Lazy.force coq_Qmake, - [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - -let parse_q term = - match Term.kind_of_term term with - | Term.App(c, args) -> if c = Lazy.force coq_Qmake then - {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } - else raise ParseError - | _ -> raise ParseError - - - let rec parse_list parse_elt term = - let (i,c) = get_left_construct term in - match i with - | 1 -> Mc.Nil - | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2)) - | i -> raise ParseError - - - let rec dump_list typ dump_elt l = - match l with - | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |]) - | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_list typ dump_elt l|]) - - let rec dump_ml_list typ dump_elt l = - match l with - | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |]) - | e::l -> Term.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_ml_list typ dump_elt l|]) - - - - let pp_list op cl elt o l = - let rec _pp o l = - match l with - | Mc.Nil -> () - | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e - | Mc.Cons(e,l) -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl - - - - let pp_var = pp_positive - let dump_var = dump_positive - - let rec pp_expr o e = - match e with - | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n - | Mc.PEc z -> pp_z o z - | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 - | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 - | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e - | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 - | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n - - - let dump_expr typ dump_z e = - let rec dump_expr e = - match e with - | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) - | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) - | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp, - [| typ; dump_expr e|]) - | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow, - [| typ; dump_expr e; dump_n n|]) - in - dump_expr e - - let rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l - - let rec dump_cone typ dump_z e = - let z = Lazy.force typ in - let rec dump_cone e = - match e with - | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |]) - | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal, - [| z; dump_expr z dump_z e ; dump_cone c |]) - | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square, - [| z;dump_expr z dump_z e|]) - | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid, - [|z; dump_monoid l|]) - | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|]) - | Mc.S_Z -> mkApp( Lazy.force coq_S_Z,[| z|]) in - dump_cone e - - - let pp_cone pp_z o e = - let rec pp_cone o e = - match e with - | Mc.S_In n -> - Printf.fprintf o "(S_In %a)%%nat" pp_nat n - | Mc.S_Ideal(e,c) -> - Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c - | Mc.S_Square e -> - Printf.fprintf o "(S_Square %a)" pp_expr e - | Mc.S_Monoid l -> - Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l - | Mc.S_Add(e1,e2) -> - Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2 - | Mc.S_Mult(e1,e2) -> - Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2 - | Mc.S_Pos p -> - Printf.fprintf o "(S_Pos %a)%%positive" pp_z p - | Mc.S_Z -> - Printf.fprintf o "S_Z" in - pp_cone o e - - - let rec dump_op = function - | Mc.OpEq-> Lazy.force coq_OpEq - | Mc.OpNEq-> Lazy.force coq_OpNEq - | Mc.OpLe -> Lazy.force coq_OpLe - | Mc.OpGe -> Lazy.force coq_OpGe - | Mc.OpGt-> Lazy.force coq_OpGt - | Mc.OpLt-> Lazy.force coq_OpLt - - - - let pp_op o e= - match e with - | Mc.OpEq-> Printf.fprintf o "=" - | Mc.OpNEq-> Printf.fprintf o "<>" - | Mc.OpLe -> Printf.fprintf o "=<" - | Mc.OpGe -> Printf.fprintf o ">=" - | Mc.OpGt-> Printf.fprintf o ">" - | Mc.OpLt-> Printf.fprintf o "<" - - - - - let pp_cstr o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = - Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr r - - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = - Term.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; - dump_expr typ dump_constant e2|]) - - let assoc_const x l = - try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - - let parse_zop (op,args) = - match kind_of_term op with - | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> - if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - - let parse_rop (op,args) = - match kind_of_term op with - | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> - if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_qop (op,args) = - (assoc_const op qop_table, args.(0) , args.(1)) - - - module Env = - struct - type t = constr list - - let compute_rank_add env v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if eq_constr e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.idx n) - - - let empty = [] - - let elements env = env - - end - - - let is_constant t = (* This is an approx *) - match kind_of_term t with - | Construct(i,_) -> true - | _ -> false - - - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power - | Ukn of string - - - let assoc_ops x l = - try - snd (List.find (fun (x',y) -> x = Lazy.force x') l) - with - Not_found -> Ukn "Oups" - - - - let parse_expr parse_constant parse_exp ops_spec env term = - if debug - then (Pp.pp (Pp.str "parse_expr: "); - Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); - - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in - - let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - match kind_of_term term with - | App(t,args) -> - ( - match kind_of_term t with - | Const c -> - ( match assoc_ops t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - let (expr,env) = parse_expr env args.(0) in - let exp = (parse_exp args.(1)) in - (Mc.PEpow(expr, exp) , env) - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) - ) - | _ -> constant_or_variable env term - ) - | _ -> constant_or_variable env term in - parse_expr env term - - - let zop_spec = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] - -let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] - -let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] - - - - - -let zconstant = parse_z -let qconstant = parse_q - - -let rconstant term = - if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "rconstant: "); - Pp.pp (Printer.prterm term); Pp.pp_flush ()); - match Term.kind_of_term term with - | Const x -> - if term = Lazy.force coq_R0 - then Mc.Z0 - else if term = Lazy.force coq_R1 - then Mc.Zpos Mc.XH - else raise ParseError - | _ -> raise ParseError - - -let parse_zexpr = - parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec -let parse_qexpr = - parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec -let parse_rexpr = - parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec - - - let parse_arith parse_op parse_expr env cstr = - if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "parse_arith: "); - Pp.pp (Printer.prterm cstr); - Pp.pp_flush ()); - match kind_of_term cstr with - | App(op,args) -> - let (op,lhs,rhs) = parse_op (op,args) in - let (e1,env) = parse_expr env lhs in - let (e2,env) = parse_expr env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) - | _ -> failwith "error : parse_arith(2)" - - let parse_zarith = parse_arith parse_zop parse_zexpr - - let parse_qarith = parse_arith parse_qop parse_qexpr - - let parse_rarith = parse_arith parse_rop parse_rexpr - - - (* generic parsing of arithmetic expressions *) - - - - - let rec f2f = function - | TT -> Mc.TT - | FF -> Mc.FF - | X _ -> Mc.X - | A (x,_) -> Mc.A x - | C (a,b,_) -> Mc.Cj(f2f a,f2f b) - | D (a,b,_) -> Mc.D(f2f a,f2f b) - | N (a,_) -> Mc.N(f2f a) - | I(a,b,_) -> Mc.I(f2f a,f2f b) - - let is_prop t = - match t with - | Names.Anonymous -> true (* Not quite right *) - | Names.Name x -> false - - let mkC f1 f2 = C(f1,f2,none) - let mkD f1 f2 = D(f1,f2,none) - let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none) - let mkI f1 f2 = I(f1,f2,none) - - let mkformula_binary g term f1 f2 = - match f1 , f2 with - | X _ , X _ -> X(term) - | _ -> g f1 f2 - - let parse_formula parse_atom env term = - let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in - - let rec xparse_formula env term = - match kind_of_term term with - | App(l,rst) -> - (match rst with - | [|a;b|] when l = Lazy.force coq_and -> - let f,env = xparse_formula env a in - let g,env = xparse_formula env b in - mkformula_binary mkC term f g,env - | [|a;b|] when l = Lazy.force coq_or -> - let f,env = xparse_formula env a in - let g,env = xparse_formula env b in - mkformula_binary mkD term f g,env - | [|a|] when l = Lazy.force coq_not -> - let (f,env) = xparse_formula env a in (N(f,none), env) - | [|a;b|] when l = Lazy.force coq_iff -> - let f,env = xparse_formula env a in - let g,env = xparse_formula env b in - mkformula_binary mkIff term f g,env - | _ -> parse_atom env term) - | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) -> - let f,env = xparse_formula env a in - let g,env = xparse_formula env b in - mkformula_binary mkI term f g,env - | _ when term = Lazy.force coq_True -> (TT,env) - | _ when term = Lazy.force coq_False -> (FF,env) - | _ -> X(term),env in - xparse_formula env term - - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") - - let dump_formula typ dump_atom f = - let rec xdump f = - match f with - | TT -> mkApp(Lazy.force coq_TT,[| typ|]) - | FF -> mkApp(Lazy.force coq_FF,[| typ|]) - | C(x,y,_) -> mkApp(Lazy.force coq_And,[| typ ; xdump x ; xdump y|]) - | D(x,y,_) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|]) - | I(x,y,_) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|]) - | N(x,_) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|]) - | A(x,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) - | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in - - xdump f - - - - - (* ! reverse the list of bindings *) - let set l concl = - let rec _set acc = function - | [] -> acc - | (e::l) -> - let (name,expr,typ) = e in - _set (Term.mkNamedLetIn - (Names.id_of_string name) - expr typ acc) l in - _set concl l - - -end - -open M - - -let rec sig_of_cone = function - | Mc.S_In n -> [CoqToCaml.nat n] - | Mc.S_Ideal(e,w) -> sig_of_cone w - | Mc.S_Mult(w1,w2) -> - (sig_of_cone w1)@(sig_of_cone w2) - | Mc.S_Add(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | _ -> [] - -let same_proof sg cl1 cl2 = - let cl1 = CoqToCaml.list (fun x -> x) cl1 in - let cl2 = CoqToCaml.list (fun x -> x) cl2 in - let rec xsame_proof sg = - match sg with - | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) - && (xsame_proof sg ) in - xsame_proof sg - - - - -let tags_of_clause tgs wit clause = - let rec xtags tgs = function - | Mc.S_In n -> Names.Idset.union tgs - (snd (List.nth clause (CoqToCaml.nat n) )) - | Mc.S_Ideal(e,w) -> xtags tgs w - | Mc.S_Mult (w1,w2) | Mc.S_Add(w1,w2) -> xtags (xtags tgs w1) w2 - | _ -> tgs in - xtags tgs wit - -let tags_of_cnf wits cnf = - List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Idset.empty wits cnf - - -let find_witness prover polys1 = - let l = CoqToCaml.list (fun x -> x) polys1 in - try_any prover l - -let rec witness prover l1 l2 = - match l2 with - | Micromega.Nil -> Some (Micromega.Nil) - | Micromega.Cons(e,l2) -> - match find_witness prover (Micromega.Cons( e,l1)) with - | None -> None - | Some w -> - (match witness prover l1 l2 with - | None -> None - | Some l -> Some (Micromega.Cons (w,l)) - ) - - -let rec apply_ids t ids = - match ids with - | [] -> t - | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids - - -let coq_Node = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - - -let btree_of_array typ a = - let size_of_a = Array.length a in - let semi_size_of_a = size_of_a lsr 1 in - let node = Lazy.force coq_Node - and leaf = Lazy.force coq_Leaf - and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in - let rec aux n = - if n > size_of_a - then empty - else if n > semi_size_of_a - then Term.mkApp (leaf, [| typ; a.(n-1) |]) - else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) - in - aux 1 - -let btree_of_array typ a = - try - btree_of_array typ a - with x -> - failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) - -let dump_varmap typ env = - btree_of_array typ (Array.of_list env) - - -let rec pp_varmap o vm = - match vm with - | Mc.Empty -> output_string o "[]" - | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z - | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r - - - -let rec dump_proof_term = function - | Micromega.RatProof cone -> - Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|]) - | Micromega.CutProof(e,q,cone,prf) -> - Term.mkApp(Lazy.force coq_cutProof, - [| dump_expr (Lazy.force coq_Z) dump_z e ; - dump_q q ; - dump_cone coq_Z dump_z cone ; - dump_proof_term prf|]) - | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) -> - Term.mkApp (Lazy.force coq_enumProof, - [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2; - dump_cone coq_Z dump_z c1 ; dump_cone coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) - -let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - - -let rec pp_proof_term o = function - | Micromega.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone - | Micromega.CutProof(e,q,_,p) -> failwith "not implemented" - | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]" - pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2 - (pp_list "[" "]" pp_proof_term) rst - -let rec parse_hyps parse_arith env hyps = - match hyps with - | [] -> ([],env) - | (i,t)::l -> - let (lhyps,env) = parse_hyps parse_arith env l in - try - let (c,env) = parse_formula parse_arith env t in - ((i,c)::lhyps, env) - with _ -> (lhyps,env) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -exception ParseError - -let parse_goal parse_arith env hyps term = - (* try*) - let (f,env) = parse_formula parse_arith env term in - let (lhyps,env) = parse_hyps parse_arith env hyps in - (lhyps,f,env) - (* with Failure x -> raise ParseError*) - - -type ('a, 'b) domain_spec = { - typ : Term.constr; (* Z, Q , R *) - coeff : Term.constr ; (* Z, Q *) - dump_coeff : 'a -> Term.constr ; - proof_typ : Term.constr ; - dump_proof : 'b -> Term.constr -} - -let zz_domain_spec = lazy { - typ = Lazy.force coq_Z; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z ; - proof_typ = Lazy.force coq_proofTerm ; - dump_proof = dump_proof_term -} - -let qq_domain_spec = lazy { - typ = Lazy.force coq_Q; - coeff = Lazy.force coq_Q; - dump_coeff = dump_q ; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_cone coq_Q dump_q -} - -let rz_domain_spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z; - proof_typ = Lazy.force coq_ZWitness ; - dump_proof = dump_cone coq_Z dump_z -} - - - - -let micromega_order_change spec cert cert_typ env ff gl = - let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - - let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap ( spec.typ) env in - Tactics.change_in_concl None - (set - [ - ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |])); - ("__varmap", vm , Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [| spec.typ|])); - ("__wit", cert,cert_typ) - ] - (Tacmach.pf_concl gl ) - - ) - gl - - -let detect_duplicates cnf wit = - let cnf = CoqToCaml.list (fun x -> x) cnf in - let wit = CoqToCaml.list (fun x -> x) wit in - - let rec xdup cnf wit = - match wit with - | [] -> [] - | w :: wit -> - let sg = sig_of_cone w in - match cnf with - | [] -> [] - | e::cnf -> - let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in - dups@(xdup cnf wit) in - xdup cnf wit - -let find_witness prover polys1 = - try_any prover polys1 - - -let witness_list_with_tags prover l = - - let rec xwitness_list l = - match l with - | [] -> Some([]) - | e::l -> - match find_witness prover (List.map fst e) with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w::l) - ) in - xwitness_list l - -let witness_list_without_tags prover l = - - let rec xwitness_list l = - match l with - | [] -> Some([]) - | e::l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w::l) - ) in - xwitness_list l - -let witness_list prover l = - let rec xwitness_list l = - match l with - | Micromega.Nil -> Some(Micromega.Nil) - | Micromega.Cons(e,l) -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (Micromega.Cons(w,l)) - ) in - xwitness_list l - - - - -let is_singleton = function [] -> true | [e] -> true | _ -> false - - -let micromega_tauto negate normalise spec prover env polys1 polys2 gl = - let spec = Lazy.force spec in - let (ff,ids) = - List.fold_right - (fun (id,f) (cc,ids) -> - match f with - X _ -> (cc,ids) - | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids)) - polys1 (polys2,[]) in - - let cnf_ff = cnf negate normalise ff in - - if debug then - (Pp.pp (Pp.str "Formula....\n") ; - let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Pp.pp (Printer.prterm ff) ; Pp.pp_flush ()) ; - - match witness_list_without_tags prover cnf_ff with - | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl - | Some res -> (*Printf.printf "\nList %i" (List.length res); *) - let (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in - let res' = dump_ml_list (spec.proof_typ) spec.dump_proof res in - (Tacticals.tclTHENSEQ - [ - Tactics.generalize ids; - micromega_order_change spec res' - (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff ; - ]) gl - - -let micromega_gen parse_arith negate normalise spec prover gl = - let concl = Tacmach.pf_concl gl in - let hyps = Tacmach.pf_hyps_types gl in - try - let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in - let env = Env.elements env in - micromega_tauto negate normalise spec prover env hyps concl gl - with - | Failure x -> flush stdout ; Pp.pp_flush () ; - Tacticals.tclFAIL 0 (Pp.str x) gl - | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl - - -let lift_ratproof prover l = - match prover l with - | None -> None - | Some c -> Some (Mc.RatProof c) - - -type csdpcert = Sos.positivstellensatz option -type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list -type provername = string * int option - -let call_csdpcert provername poly = - let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in - let tmp_from = Filename.temp_file "csdpcert" ".out" in - output_value ch_to (provername,poly : provername * micromega_polys); - close_out ch_to; - let cmdname = - List.fold_left Filename.concat (Envars.coqlib ()) - ["contrib"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in - let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in - (try Sys.remove tmp_to with _ -> ()); - if c <> 0 then Util.error ("Failed to call csdp certificate generator"); - let ch_from = open_in tmp_from in - let cert = (input_value ch_from : csdpcert) in - close_in ch_from; Sys.remove tmp_from; - cert - -let rec z_to_q_expr e = - match e with - | Mc.PEc z -> Mc.PEc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.PEX x -> Mc.PEX x - | Mc.PEadd(e1,e2) -> Mc.PEadd(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEsub(e1,e2) -> Mc.PEsub(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEmul(e1,e2) -> Mc.PEmul(z_to_q_expr e1, z_to_q_expr e2) - | Mc.PEopp(e) -> Mc.PEopp(z_to_q_expr e) - | Mc.PEpow(e,n) -> Mc.PEpow(z_to_q_expr e,n) - - -let call_csdpcert_q provername poly = - match call_csdpcert provername poly with - | None -> None - | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - match Mc.qWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with - | Mc.True -> Some cert - | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None - - -let call_csdpcert_z provername poly = - let l = List.map (fun (Mc.Pair(e,o)) -> (Mc.Pair(z_to_q_expr e,o))) poly in - match call_csdpcert provername l with - | None -> None - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - match Mc.zWeakChecker (CamlToCoq.list (fun x -> x) poly) cert with - | Mc.True -> Some cert - | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None - - - - -let psatzl_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof - (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl - - -let psatzl_Q gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl - -let psatz_Q i gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [ call_csdpcert_q ("real_nonlinear_prover", Some i), "fourier refutation" ] gl - -let psatzl_R gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl - - -let psatz_R i gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [ call_csdpcert_z ("real_nonlinear_prover", Some i), "fourier refutation" ] gl - - -let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof (call_csdpcert_z ("real_nonlinear_prover",Some i)), - "fourier refutation" ] gl - - -let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [lift_ratproof (call_csdpcert_z ("pure_sos", None)), "pure sos refutation"] gl - -let sos_Q gl = - micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec - [call_csdpcert_q ("pure_sos", None), "pure sos refutation"] gl - -let sos_R gl = - micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec - [call_csdpcert_z ("pure_sos", None), "pure sos refutation"] gl - - - -let xlia gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [Certificate.zlinear_prover, "zprover"] gl diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml deleted file mode 100644 index e451a38f..00000000 --- a/contrib/micromega/csdpcert.ml +++ /dev/null @@ -1,197 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -open Big_int -open Num -open Sos - -module Mc = Micromega -module Ml2C = Mutils.CamlToCoq -module C2Ml = Mutils.CoqToCaml - -let debug = false - -module M = -struct - open Mc - - let rec expr_to_term = function - | PEc z -> Const (C2Ml.q_to_num z) - | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) - | PEmul(p1,p2) -> - let p1 = expr_to_term p1 in - let p2 = expr_to_term p2 in - let res = Mul(p1,p2) in res - - | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2) - | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2) - | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) - | PEopp p -> Opp (expr_to_term p) - - - - -(* let term_to_expr e = - let e' = term_to_expr e in - if debug - then Printf.printf "term_to_expr : %s - %s\n" - (string_of_poly (poly_of_term e)) - (string_of_poly (poly_of_term (expr_to_term e'))); - e' *) - -end -open M - -open List -open Mutils - - - - -let rec canonical_sum_to_string = function s -> failwith "not implemented" - -let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) - -let print_list_term l = - print_string "print_list_term\n"; - List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " - | _ -> failwith "not_implemented")) l ; - print_string "\n" - - -let partition_expr l = - let rec f i = function - | [] -> ([],[],[]) - | Mc.Pair(e,k)::l -> - let (eq,ge,neq) = f (i+1) l in - match k with - | Mc.Equal -> ((e,i)::eq,ge,neq) - | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) - | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) - (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) - | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) - (* Not quite sure -- Coq interface has changed *) - in f 0 l - - -let rec sets_of_list l = - match l with - | [] -> [[]] - | e::l -> let s = sets_of_list l in - s@(List.map (fun s0 -> e::s0) s) - -(* The exploration is probably not complete - for simple cases, it works... *) -let real_nonlinear_prover d l = - try - let (eq,ge,neq) = partition_expr l in - - let rec elim_const = function - [] -> [] - | (x,y)::l -> let p = poly_of_term (expr_to_term x) in - if poly_isconst p - then elim_const l - else (p,y)::(elim_const l) in - - let eq = elim_const eq in - let peq = List.map fst eq in - - let pge = List.map - (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in - - let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> - let p = poly_of_term (expr_to_term p) in - match kd with - | Axiom_lt i -> poly_mul p y - | Axiom_eq i -> poly_mul (poly_pow p 2) y - | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m)) - (sets_of_list neq) in - - let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - list_try_find (fun m -> let (ci,cc) = - real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in - (ci,cc,snd m)) monoids) 0 in - - let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) - cert_ideal (List.map snd eq) in - - let proofs_cone = map term_of_sos cert_cone in - - let proof_ne = - let (neq , lt) = List.partition - (function Axiom_eq _ -> true | _ -> false ) monoid in - let sq = match - (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) - with - | [] -> Rational_lt (Int 1) - | l -> Monoid l in - List.fold_right (fun x y -> Product(x,y)) lt sq in - - let proof = list_fold_right_elements - (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in - Some proof - with - | Sos.TooDeep -> None - - -(* This is somewhat buggy, over Z, strict inequality vanish... *) -let pure_sos l = - (* If there is no strict inequality, - I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) - try - let l = List.combine l (interval 0 (length l -1)) in - let (lt,i) = try (List.find (fun (x,_) -> snd' x = Mc.Strict) l) - with Not_found -> List.hd l in - let plt = poly_neg (poly_of_term (expr_to_term (fst' lt))) in - let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) - let pos = Product (Rational_lt n, - List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square - (term_of_poly p)), rst)) - polys (Rational_lt (Int 0))) in - let proof = Sum(Axiom_lt i, pos) in -(* let s,proof' = scale_certificate proof in - let cert = snd (cert_of_pos proof') in *) - Some proof - with - | Not_found -> (* This is no strict inequality *) None - | x -> None - - -type micromega_polys = (Micromega.q Mc.pExpr, Mc.op1) Micromega.prod list -type csdp_certificate = Sos.positivstellensatz option -type provername = string * int option - -let main () = - if Array.length Sys.argv <> 3 then - (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1); - let input_file = Sys.argv.(1) in - let output_file = Sys.argv.(2) in - let inch = open_in input_file in - let (prover,poly) = (input_value inch : provername * micromega_polys) in - close_in inch; - let cert = - match prover with - | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly - | "pure_sos", None -> pure_sos poly - | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in - let outch = open_out output_file in - output_value outch (cert:csdp_certificate); - close_out outch; - exit 0;; - -let _ = main () in () diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4 deleted file mode 100644 index 50024e78..00000000 --- a/contrib/micromega/g_micromega.ml4 +++ /dev/null @@ -1,74 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_micromega.ml4 11306 2008-08-05 16:51:08Z notin $ *) - -open Quote -open Ring -open Mutils -open Rawterm -open Util - -let out_arg = function - | ArgVar _ -> anomaly "Unevaluated or_var variable" - | ArgArg x -> x - -TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ] -| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ] -END - -TACTIC EXTEND Sos_Z -| [ "sos_Z" ] -> [ Coq_micromega.sos_Z] - END - -TACTIC EXTEND Sos_Q -| [ "sos_Q" ] -> [ Coq_micromega.sos_Q] - END - -TACTIC EXTEND Sos_R -| [ "sos_R" ] -> [ Coq_micromega.sos_R] -END - - -TACTIC EXTEND Omicron -[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z] -END - -TACTIC EXTEND QOmicron -[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] -END - - -TACTIC EXTEND ZOmicron -[ "xlia" ] -> [ Coq_micromega.xlia] -END - -TACTIC EXTEND ROmicron -[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] -END - -TACTIC EXTEND RMicromega -| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ] -| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ] -END - - -TACTIC EXTEND QMicromega -| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ] -| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ] -END - diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml deleted file mode 100644 index 415d3a3e..00000000 --- a/contrib/micromega/mfourier.ml +++ /dev/null @@ -1,667 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -(* Yet another implementation of Fourier *) -open Num - -module Cmp = - (* How to compare pairs, lists ... *) -struct - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> - let cmp = f () in - if cmp = 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> - let c = cmp e1 e2 in - if c = 0 then compare_list cmp l1 l2 else c - - let hash_list hash l = - let rec xhash res l = - match l with - | [] -> res - | e::l -> xhash ((hash e) lxor res) l in - xhash (Hashtbl.hash []) l - -end - -module Interval = -struct - (** The type of intervals. **) - type intrvl = Empty | Point of num | Itv of num option * num option - - (** - Different intervals can denote the same set of variables e.g., - Point n && Itv (Some n, Some n) - Itv (Some x) (Some y) && Empty if x > y - see the 'belongs_to' function. - **) - - (* The set of numerics that belong to an interval *) - let belongs_to n = function - | Empty -> false - | Point x -> n =/ x - | Itv(Some x, Some y) -> x <=/ n && n <=/ y - | Itv(None,Some y) -> n <=/ y - | Itv(Some x,None) -> x <=/ n - | Itv(None,None) -> true - - let string_of_bound = function - | None -> "oo" - | Some n -> Printf.sprintf "Bd(%s)" (string_of_num n) - - let string_of_intrvl = function - | Empty -> "[]" - | Point n -> Printf.sprintf "[%s]" (string_of_num n) - | Itv(bd1,bd2) -> - Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2) - - let pick_closed_to_zero = function - | Empty -> None - | Point n -> Some n - | Itv(None,None) -> Some (Int 0) - | Itv(None,Some i) -> - Some (if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i) - | Itv(Some i,None) -> - Some (if i <=/ (Int 0) then Int 0 else ceiling_num i) - | Itv(Some i,Some j) -> - Some ( - if i <=/ Int 0 && Int 0 <=/ j - then Int 0 - else if ceiling_num i <=/ floor_num j - then ceiling_num i (* why not *) else i) - - type status = - | O | Qonly | Z | Q - - let interval_kind = function - | Empty -> O - | Point n -> if ceiling_num n =/ n then Z else Qonly - | Itv(None,None) -> Z - | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z - | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z - | Itv(Some i,Some j) -> - if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z - - let empty_z = function - | Empty -> true - | Point n -> ceiling_num n <>/ n - | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false - | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j - - - let normalise b1 b2 = - match b1 , b2 with - | Some i , Some j -> - (match compare_num i j with - | 1 -> Empty - | 0 -> Point i - | _ -> Itv(b1,b2) - ) - | _ -> Itv(b1,b2) - - - - let min x y = - match x , y with - | None , x | x , None -> x - | Some i , Some j -> Some (min_num i j) - - let max x y = - match x , y with - | None , x | x , None -> x - | Some i , Some j -> Some (max_num i j) - - let inter i1 i2 = - match i1,i2 with - | Empty , _ -> Empty - | _ , Empty -> Empty - | Point n , Point m -> if n =/ m then i1 else Empty - | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n-> - if (match mn with - | None -> true - | Some mn -> mn <=/ n) && - (match mx with - | None -> true - | Some mx -> n <=/ mx) then Point n else Empty - | Itv (min1,max1) , Itv (min2,max2) -> - let bmin = max min1 min2 - and bmax = min max1 max2 in - normalise bmin bmax - - (* a.x >= b*) - let bound_of_constraint (a,b) = - match compare_num a (Int 0) with - | 0 -> - if compare_num b (Int 0) = 1 - then Empty - (*actually this is a contradiction failwith "bound_of_constraint" *) - else Itv (None,None) - | 1 -> Itv (Some (div_num b a),None) - | -1 -> Itv (None, Some (div_num b a)) - | x -> failwith "bound_of_constraint(2)" - - - let bounded x = - match x with - | Itv(None,_) | Itv(_,None) -> false - | _ -> true - - - let range = function - | Empty -> Some (Int 0) - | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0)) - | Itv(None,_) | Itv(_,None)-> None - | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - (* Returns the interval of smallest range *) - let smaller_itv i1 i2 = - match range i1 , range i2 with - | None , _ -> false - | _ , None -> true - | Some i , Some j -> i <=/ j - -end -open Interval - -(* A set of constraints *) -module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) = -struct - - module Vect = V - - module Cstr = Vector.Cstr(V) - open Cstr - - - module CMap = Map.Make( - struct - type t = Vect.t - let compare = Vect.compare - end) - - module CstrBag = - struct - - type mut_itv = { mutable itv : intrvl} - - type t = mut_itv CMap.t - - exception Contradiction - - let cstr_to_itv cstr = - let (n,l) = V.normalise cstr.coeffs in - if n =/ (Int 0) - then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *) - else - match cstr.op with - | Eq -> let n = cstr.cst // n in (l, Point n) - | Ge -> - match compare_num n (Int 0) with - | 0 -> failwith "intrvl_of_constraint" - | 1 -> (l,Itv (Some (cstr.cst // n), None)) - | -1 -> (l, Itv(None,Some (cstr.cst // n))) - | _ -> failwith "cstr_to_itv" - - - let empty = CMap.empty - - - - - let is_empty = CMap.is_empty - - let find_vect v bag = - try - (bag,CMap.find v bag) - with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x) - - - let add (v,b) bag = - match b with - | Empty -> raise Contradiction - | Itv(None,None) -> bag - | _ -> - let (bag,intrl) = find_vect v bag in - match inter b intrl.itv with - | Empty -> raise Contradiction - | itv -> intrl.itv <- itv ; bag - - exception Found of cstr - - let find_equation bag = - try - CMap.fold (fun v i () -> - match i.itv with - | Point n -> let e = {coeffs = v ; op = Eq ; cst = n} - in raise (Found e) - | _ -> () ) bag () ; None - with Found c -> Some c - - - let fold f bag acc = - CMap.fold (fun v itv acc -> - match itv.itv with - | Empty | Itv(None,None) -> failwith "fold Empty" - | Itv(None ,Some i) -> - f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc - | Point n -> f {coeffs = v ; op = Eq ; cst = n} acc - | Itv(x,y) -> - (match x with - | None -> (fun x -> x) - | Some i -> f {coeffs = v ; op = Ge ; cst = i}) - (match y with - | None -> acc - | Some i -> - f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc - ) ) bag acc - - - let remove l _ = failwith "remove:Not implemented" - - module Map = - Map.Make( - struct - type t = int - let compare : int -> int -> int = Pervasives.compare - end) - - let split f (t:t) = - let res = - fold (fun e m -> let i = f e in - Map.add i (add (cstr_to_itv e) - (try Map.find i m with - Not_found -> empty)) m) t Map.empty in - (fun i -> try Map.find i res with Not_found -> empty) - - type map = (int list * int list) Map.t - - - let status (b:t) = - let _ , map = fold (fun c ( (idx:int),(res: map)) -> - ( idx + 1, - List.fold_left (fun (res:map) (pos,s) -> - let (lp,ln) = try Map.find pos res with Not_found -> ([],[]) in - match s with - | Vect.Pos -> Map.add pos (idx::lp,ln) res - | Vect.Neg -> - Map.add pos (lp, idx::ln) res) res - (Vect.status c.coeffs))) b (0,Map.empty) in - Map.fold (fun k e res -> (k,e)::res) map [] - - - type it = num CMap.t - - let iterator x = x - - let element it = failwith "element:Not implemented" - - end -end - -module Fourier(Vect : Vector.S) = -struct - module Vect = Vect - module Sys = Sys( Vect) - module Cstr = Sys.Cstr - module Bag = Sys.CstrBag - - open Cstr - open Sys - - let debug = false - - let print_bag msg b = - print_endline msg; - CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b () - - let print_bag_file file msg b = - let f = open_out file in - output_string f msg; - CstrBag.fold (fun e () -> - Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b () - - - (* A system with only inequations -- - *) - let partition i m = - let splitter cstr = compare_num (Vect.get i cstr.coeffs ) (Int 0) in - let split = CstrBag.split splitter m in - (split (-1) , split 0, split 1) - - - (* op of the result is arbitrary Ge *) - let lin_comb n1 c1 n2 c2 = - { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ; - op = Ge ; - cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)} - - (* BUG? : operator of the result ? *) - - let combine_project i c1 c2 = - let p = Vect.get i c1.coeffs - and n = Vect.get i c2.coeffs in - assert (n </ Int 0 && p >/ Int 0) ; - let nopp = minus_num n in - let c =lin_comb nopp c1 p c2 in - let op = if c1.op = Ge || c2.op = Ge then Ge else Eq in - CstrBag.cstr_to_itv {coeffs = c.coeffs ; op = op ; cst= c.cst } - - - let project i m = - let (neg,zero,pos) = partition i m in - let project1 cpos acc = - CstrBag.fold (fun cneg res -> - CstrBag.add (combine_project i cpos cneg) res) neg acc in - (CstrBag.fold project1 pos zero) - - (* Given a vector [x1 -> v1; ... ; xn -> vn] - and a constraint {x1 ; .... xn >= c } - *) - let evaluate_constraint i map cstr = - let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in - let vi = Vect.get i _coeffs in - let v = Vect.set i (Int 0) _coeffs in - (vi, _cst -/ Vect.dotp map v) - - - let rec bounds m itv = - match m with - | [] -> itv - | e::m -> bounds m (inter itv (bound_of_constraint e)) - - - - let compare_status (i,(lp,ln)) (i',(lp',ln')) = - let cmp = Pervasives.compare - ((List.length lp) * (List.length ln)) - ((List.length lp') * (List.length ln')) in - if cmp = 0 - then Pervasives.compare i i' - else cmp - - let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0 - - let lightest_projection l c m = - let bound = c in - if debug then (Printf.printf "l%i" bound; flush stdout) ; - let rec xlight best l = - match l with - | [] -> best - | i::l -> - let proj = (project i m) in - let cproj = cardinal proj in - (*Printf.printf " p %i " cproj; flush stdout;*) - match best with - | None -> - if cproj < bound - then Some(cproj,proj,i) - else xlight (Some(cproj,proj,i)) l - | Some (cbest,_,_) -> - if cproj < cbest - then - if cproj < bound then Some(cproj,proj,i) - else xlight (Some(cproj,proj,i)) l - else xlight best l in - match xlight None l with - | None -> None - | Some(_,p,i) -> Some (p,i) - - - - exception Equality of cstr - - let find_equality m = Bag.find_equation m - - - - let pivot (n,v) eq ge = - assert (eq.op = Eq) ; - let res = - match - compare_num v (Int 0), - compare_num (Vect.get n ge.coeffs) (Int 0) - with - | 0 , _ -> failwith "Buggy" - | _ ,0 -> (CstrBag.cstr_to_itv ge) - | 1 , -1 -> combine_project n eq ge - | -1 , 1 -> combine_project n ge eq - | 1 , 1 -> - combine_project n ge - {coeffs = Vect.mul (Int (-1)) eq.coeffs; - op = eq.op ; - cst = minus_num eq.cst} - | -1 , -1 -> - combine_project n - {coeffs = Vect.mul (Int (-1)) eq.coeffs; - op = eq.op ; cst = minus_num eq.cst} ge - | _ -> failwith "pivot" in - res - - let check_cstr v c = - let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in - let vl = Vect.dotp v _coeffs in - match _op with - | Eq -> vl =/ _cst - | Ge -> vl >= _cst - - - let forall p sys = - try - CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true - with Not_found -> false - - - let check_sys v sys = forall (check_cstr v) sys - - let check_null_cstr c = - let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in - match _op with - | Eq -> (Int 0) =/ _cst - | Ge -> (Int 0) >= _cst - - let check_null sys = forall check_null_cstr sys - - - let optimise_ge - quick_check choose choose_idx return_empty return_ge return_eq m = - let c = cardinal m in - let bound = 2 * c in - if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout); - - let rec xoptimise m = - if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout); - if debug then (print_bag "xoptimise" m ; flush stdout); - if quick_check m - then return_empty m - else - match find_equality m with - | None -> xoptimise_ge m - | Some eq -> xoptimise_eq eq m - - and xoptimise_ge m = - begin - let c = cardinal m in - let l = List.map fst (List.sort compare_status (CstrBag.status m)) in - let idx = choose bound l c m in - match idx with - | None -> return_empty m - | Some (proj,i) -> - match xoptimise proj with - | None -> None - | Some mapping -> return_ge m i mapping - end - and xoptimise_eq eq m = - let l = List.map fst (Vect.status eq.coeffs) in - match choose_idx l with - | None -> (*if l = [] then None else*) return_empty m - | Some i -> - let p = (i,Vect.get i eq.coeffs) in - let m' = CstrBag.fold - (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in - match xoptimise ( m') with - | None -> None - | Some mapp -> return_eq m eq i mapp in - try - let res = xoptimise m in res - with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None - - - - let minimise m = - let opt_zero_choose bound l c m = - if c > bound - then lightest_projection l c m - else match l with - | [] -> None - | i::_ -> Some (project i m, i) in - - let choose_idx = function [] -> None | x::l -> Some x in - - let opt_zero_return_empty m = Some Vect.null in - - - let opt_zero_return_ge m i mapping = - let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter - (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m - (Itv (None, None)) in - match pick_closed_to_zero it with - | None -> print_endline "Cannot pick" ; None - | Some v -> - let res = (Vect.set i v mapping) in - if debug - then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ; - Some res in - - let opt_zero_return_eq m eq i mapp = - let (a,b) = evaluate_constraint i mapp eq in - Some (Vect.set i (div_num b a) mapp) in - - optimise_ge check_null opt_zero_choose - choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq m - - let normalise cstr = [CstrBag.cstr_to_itv cstr] - - let find_point l = - (* List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*) - try - let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys) - CstrBag.empty l in - match minimise m with - | None -> None - | Some res -> - if debug then Printf.printf "[%s]" (Vect.string res); - Some res - with CstrBag.Contradiction -> None - - - let find_q_interval_for x m = - if debug then Printf.printf "find_q_interval_for %i\n" x ; - - let choose bound l c m = - let rec xchoose l = - match l with - | [] -> None - | i::l -> if i = x then xchoose l else Some (project i m,i) in - xchoose l in - - let rec choose_idx = function - [] -> None - | e::l -> if e = x then choose_idx l else Some e in - - let return_empty m = (* Beurk *) - (* returns the interval of x *) - Some (CstrBag.fold (fun cstr itv -> - let i = if cstr.op = Eq - then Point (cstr.cst // Vect.get x cstr.coeffs) - else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs) - then bound_of_constraint (Vect.get x cstr.coeffs , cstr.cst) - else itv - in - Interval.inter i itv) m (Itv (None, None))) in - - let return_ge m i res = Some res in - - let return_eq m eq i res = Some res in - - try - optimise_ge - (fun x -> false) choose choose_idx return_empty return_ge return_eq m - with CstrBag.Contradiction -> None - - - let find_q_intervals sys = - let variables = - List.map fst (List.sort compare_status (CstrBag.status sys)) in - List.map (fun x -> (x,find_q_interval_for x sys)) variables - - let pp_option f o = function - None -> Printf.fprintf o "None" - | Some x -> Printf.fprintf o "Some %a" f x - - let optimise vect sys = - (* we have to modify the system with a dummy variable *) - let fresh = - List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in - assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys); - let cstr = { - coeffs = Vect.set fresh (Int (-1)) vect ; - op = Eq ; - cst = (Int 0)} in - try - find_q_interval_for fresh - (List.fold_left - (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) - CstrBag.empty (cstr::sys)) - with CstrBag.Contradiction -> None - - - let optimise vect sys = - let res = optimise vect sys in - if debug - then Printf.printf "optimise %s -> %a\n" - (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res - ; res - - let find_Q_interval sys = - try - let sys = - (List.fold_left - (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) CstrBag.empty sys) in - let candidates = - List.fold_left - (fun l (x,i) -> match i with - None -> (x,Empty)::l - | Some i -> (x,i)::l) [] (find_q_intervals sys) in - match List.fold_left - (fun (x1,i1) (x2,i2) -> - if smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates - with - | (i,Empty) -> None - | (x,Itv(Some i, Some j)) -> Some(i,x,j) - | (x,Point n) -> Some(n,x,n) - | _ -> None - with CstrBag.Contradiction -> None - - -end - diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml deleted file mode 100644 index e151e4e1..00000000 --- a/contrib/micromega/micromega.ml +++ /dev/null @@ -1,1512 +0,0 @@ -type __ = Obj.t -let __ = let rec f _ = Obj.repr f in Obj.repr f - -type bool = - | True - | False - -(** val negb : bool -> bool **) - -let negb = function - | True -> False - | False -> True - -type nat = - | O - | S of nat - -type 'a option = - | Some of 'a - | None - -type ('a, 'b) prod = - | Pair of 'a * 'b - -type comparison = - | Eq - | Lt - | Gt - -(** val compOpp : comparison -> comparison **) - -let compOpp = function - | Eq -> Eq - | Lt -> Gt - | Gt -> Lt - -type sumbool = - | Left - | Right - -type 'a sumor = - | Inleft of 'a - | Inright - -type 'a list = - | Nil - | Cons of 'a * 'a list - -(** val app : 'a1 list -> 'a1 list -> 'a1 list **) - -let rec app l m = - match l with - | Nil -> m - | Cons (a, l1) -> Cons (a, (app l1 m)) - -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) - -let rec nth n0 l default = - match n0 with - | O -> (match l with - | Nil -> default - | Cons (x, l') -> x) - | S m -> - (match l with - | Nil -> default - | Cons (x, t0) -> nth m t0 default) - -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) - -let rec map f = function - | Nil -> Nil - | Cons (a, t0) -> Cons ((f a), (map f t0)) - -type positive = - | XI of positive - | XO of positive - | XH - -(** val psucc : positive -> positive **) - -let rec psucc = function - | XI p -> XO (psucc p) - | XO p -> XI p - | XH -> XO XH - -(** val pplus : positive -> positive -> positive **) - -let rec pplus x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (pplus_carry p q0) - | XO q0 -> XI (pplus p q0) - | XH -> XO (psucc p)) - | XO p -> - (match y with - | XI q0 -> XI (pplus p q0) - | XO q0 -> XO (pplus p q0) - | XH -> XI p) - | XH -> - (match y with - | XI q0 -> XO (psucc q0) - | XO q0 -> XI q0 - | XH -> XO XH) - -(** val pplus_carry : positive -> positive -> positive **) - -and pplus_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (pplus_carry p q0) - | XO q0 -> XO (pplus_carry p q0) - | XH -> XI (psucc p)) - | XO p -> - (match y with - | XI q0 -> XO (pplus_carry p q0) - | XO q0 -> XI (pplus p q0) - | XH -> XO (psucc p)) - | XH -> - (match y with - | XI q0 -> XI (psucc q0) - | XO q0 -> XO (psucc q0) - | XH -> XI XH) - -(** val p_of_succ_nat : nat -> positive **) - -let rec p_of_succ_nat = function - | O -> XH - | S x -> psucc (p_of_succ_nat x) - -(** val pdouble_minus_one : positive -> positive **) - -let rec pdouble_minus_one = function - | XI p -> XI (XO p) - | XO p -> XI (pdouble_minus_one p) - | XH -> XH - -type positive_mask = - | IsNul - | IsPos of positive - | IsNeg - -(** val pdouble_plus_one_mask : positive_mask -> positive_mask **) - -let pdouble_plus_one_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - -(** val pdouble_mask : positive_mask -> positive_mask **) - -let pdouble_mask = function - | IsNul -> IsNul - | IsPos p -> IsPos (XO p) - | IsNeg -> IsNeg - -(** val pdouble_minus_two : positive -> positive_mask **) - -let pdouble_minus_two = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pdouble_minus_one p)) - | XH -> IsNul - -(** val pminus_mask : positive -> positive -> positive_mask **) - -let rec pminus_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> pdouble_mask (pminus_mask p q0) - | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_mask (pminus_mask p q0) - | XH -> IsPos (pdouble_minus_one p)) - | XH -> (match y with - | XH -> IsNul - | _ -> IsNeg) - -(** val pminus_mask_carry : positive -> positive -> positive_mask **) - -and pminus_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_mask (pminus_mask p q0) - | XH -> IsPos (pdouble_minus_one p)) - | XO p -> - (match y with - | XI q0 -> pdouble_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XH -> pdouble_minus_two p) - | XH -> IsNeg - -(** val pminus : positive -> positive -> positive **) - -let pminus x y = - match pminus_mask x y with - | IsPos z0 -> z0 - | _ -> XH - -(** val pmult : positive -> positive -> positive **) - -let rec pmult x y = - match x with - | XI p -> pplus y (XO (pmult p y)) - | XO p -> XO (pmult p y) - | XH -> y - -(** val pcompare : positive -> positive -> comparison -> comparison **) - -let rec pcompare x y r = - match x with - | XI p -> - (match y with - | XI q0 -> pcompare p q0 r - | XO q0 -> pcompare p q0 Gt - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> pcompare p q0 Lt - | XO q0 -> pcompare p q0 r - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - -type n = - | N0 - | Npos of positive - -type z = - | Z0 - | Zpos of positive - | Zneg of positive - -(** val zdouble_plus_one : z -> z **) - -let zdouble_plus_one = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (pdouble_minus_one p) - -(** val zdouble_minus_one : z -> z **) - -let zdouble_minus_one = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (pdouble_minus_one p) - | Zneg p -> Zneg (XI p) - -(** val zdouble : z -> z **) - -let zdouble = function - | Z0 -> Z0 - | Zpos p -> Zpos (XO p) - | Zneg p -> Zneg (XO p) - -(** val zPminus : positive -> positive -> z **) - -let rec zPminus x y = - match x with - | XI p -> - (match y with - | XI q0 -> zdouble (zPminus p q0) - | XO q0 -> zdouble_plus_one (zPminus p q0) - | XH -> Zpos (XO p)) - | XO p -> - (match y with - | XI q0 -> zdouble_minus_one (zPminus p q0) - | XO q0 -> zdouble (zPminus p q0) - | XH -> Zpos (pdouble_minus_one p)) - | XH -> - (match y with - | XI q0 -> Zneg (XO q0) - | XO q0 -> Zneg (pdouble_minus_one q0) - | XH -> Z0) - -(** val zplus : z -> z -> z **) - -let zplus x y = - match x with - | Z0 -> y - | Zpos x' -> - (match y with - | Z0 -> Zpos x' - | Zpos y' -> Zpos (pplus x' y') - | Zneg y' -> - (match pcompare x' y' Eq with - | Eq -> Z0 - | Lt -> Zneg (pminus y' x') - | Gt -> Zpos (pminus x' y'))) - | Zneg x' -> - (match y with - | Z0 -> Zneg x' - | Zpos y' -> - (match pcompare x' y' Eq with - | Eq -> Z0 - | Lt -> Zpos (pminus y' x') - | Gt -> Zneg (pminus x' y')) - | Zneg y' -> Zneg (pplus x' y')) - -(** val zopp : z -> z **) - -let zopp = function - | Z0 -> Z0 - | Zpos x0 -> Zneg x0 - | Zneg x0 -> Zpos x0 - -(** val zminus : z -> z -> z **) - -let zminus m n0 = - zplus m (zopp n0) - -(** val zmult : z -> z -> z **) - -let zmult x y = - match x with - | Z0 -> Z0 - | Zpos x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zpos (pmult x' y') - | Zneg y' -> Zneg (pmult x' y')) - | Zneg x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zneg (pmult x' y') - | Zneg y' -> Zpos (pmult x' y')) - -(** val zcompare : z -> z -> comparison **) - -let zcompare x y = - match x with - | Z0 -> (match y with - | Z0 -> Eq - | Zpos y' -> Lt - | Zneg y' -> Gt) - | Zpos x' -> (match y with - | Zpos y' -> pcompare x' y' Eq - | _ -> Gt) - | Zneg x' -> - (match y with - | Zneg y' -> compOpp (pcompare x' y' Eq) - | _ -> Lt) - -(** val dcompare_inf : comparison -> sumbool sumor **) - -let dcompare_inf = function - | Eq -> Inleft Left - | Lt -> Inleft Right - | Gt -> Inright - -(** val zcompare_rec : - z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - -let zcompare_rec x y h1 h2 h3 = - match dcompare_inf (zcompare x y) with - | Inleft x0 -> (match x0 with - | Left -> h1 __ - | Right -> h2 __) - | Inright -> h3 __ - -(** val z_gt_dec : z -> z -> sumbool **) - -let z_gt_dec x y = - zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left) - -(** val zle_bool : z -> z -> bool **) - -let zle_bool x y = - match zcompare x y with - | Gt -> False - | _ -> True - -(** val zge_bool : z -> z -> bool **) - -let zge_bool x y = - match zcompare x y with - | Lt -> False - | _ -> True - -(** val zgt_bool : z -> z -> bool **) - -let zgt_bool x y = - match zcompare x y with - | Gt -> True - | _ -> False - -(** val zeq_bool : z -> z -> bool **) - -let zeq_bool x y = - match zcompare x y with - | Eq -> True - | _ -> False - -(** val n_of_nat : nat -> n **) - -let n_of_nat = function - | O -> N0 - | S n' -> Npos (p_of_succ_nat n') - -(** val zdiv_eucl_POS : positive -> z -> (z, z) prod **) - -let rec zdiv_eucl_POS a b = - match a with - | XI a' -> - let Pair (q0, r) = zdiv_eucl_POS a' b in - let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in - (match zgt_bool b r' with - | True -> Pair ((zmult (Zpos (XO XH)) q0), r') - | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)), - (zminus r' b))) - | XO a' -> - let Pair (q0, r) = zdiv_eucl_POS a' b in - let r' = zmult (Zpos (XO XH)) r in - (match zgt_bool b r' with - | True -> Pair ((zmult (Zpos (XO XH)) q0), r') - | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)), - (zminus r' b))) - | XH -> - (match zge_bool b (Zpos (XO XH)) with - | True -> Pair (Z0, (Zpos XH)) - | False -> Pair ((Zpos XH), Z0)) - -(** val zdiv_eucl : z -> z -> (z, z) prod **) - -let zdiv_eucl a b = - match a with - | Z0 -> Pair (Z0, Z0) - | Zpos a' -> - (match b with - | Z0 -> Pair (Z0, Z0) - | Zpos p -> zdiv_eucl_POS a' b - | Zneg b' -> - let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in - (match r with - | Z0 -> Pair ((zopp q0), Z0) - | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r)))) - | Zneg a' -> - (match b with - | Z0 -> Pair (Z0, Z0) - | Zpos p -> - let Pair (q0, r) = zdiv_eucl_POS a' b in - (match r with - | Z0 -> Pair ((zopp q0), Z0) - | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r))) - | Zneg b' -> - let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in - Pair (q0, (zopp r))) - -type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol - -(** val p0 : 'a1 -> 'a1 pol **) - -let p0 cO = - Pc cO - -(** val p1 : 'a1 -> 'a1 pol **) - -let p1 cI = - Pc cI - -(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **) - -let rec peq ceqb p p' = - match p with - | Pc c -> (match p' with - | Pc c' -> ceqb c c' - | _ -> False) - | Pinj (j, q0) -> - (match p' with - | Pinj (j', q') -> - (match pcompare j j' Eq with - | Eq -> peq ceqb q0 q' - | _ -> False) - | _ -> False) - | PX (p2, i, q0) -> - (match p' with - | PX (p'0, i', q') -> - (match pcompare i i' Eq with - | Eq -> - (match peq ceqb p2 p'0 with - | True -> peq ceqb q0 q' - | False -> False) - | _ -> False) - | _ -> False) - -(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) - -let mkPinj_pred j p = - match j with - | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((pdouble_minus_one j0), p) - | XH -> p - -(** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let mkPX cO ceqb p i q0 = - match p with - | Pc c -> - (match ceqb c cO with - | True -> - (match q0 with - | Pc c0 -> q0 - | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p2, p3, p4) -> Pinj (XH, q0)) - | False -> PX (p, i, q0)) - | Pinj (p2, p3) -> PX (p, i, q0) - | PX (p', i', q') -> - (match peq ceqb q' (p0 cO) with - | True -> PX (p', (pplus i' i), q0) - | False -> PX (p, i, q0)) - -(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mkXi cO cI i = - PX ((p1 cI), i, (p0 cO)) - -(** val mkX : 'a1 -> 'a1 -> 'a1 pol **) - -let mkX cO cI = - mkXi cO cI XH - -(** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) - -let rec popp copp = function - | Pc c -> Pc (copp c) - | Pinj (j, q0) -> Pinj (j, (popp copp q0)) - | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) - -(** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec paddC cadd p c = - match p with - | Pc c1 -> Pc (cadd c1 c) - | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) - -(** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) - -let rec psubC csub p c = - match p with - | Pc c1 -> Pc (csub c1 c) - | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) - -(** val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol **) - -let rec paddI cadd pop q0 j = function - | Pc c -> - let p2 = paddC cadd q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pop q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pop (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = paddI cadd pop q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubI cadd copp pop q0 j = function - | Pc c -> - let p2 = paddC cadd (popp copp q0) c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pop q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pop (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = psubI cadd copp pop q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, - (psubI cadd copp pop q0 (pdouble_minus_one j0) q')) - | XH -> PX (p2, i, (pop q' q0))) - -(** val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol **) - -let rec paddX cO ceqb pop p' i' p = match p with - | Pc c -> PX (p', i', p) - | Pinj (j, q') -> - (match j with - | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q'))) - | XH -> PX (p', i', q')) - | PX (p2, i, q') -> - (match zPminus i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') - -(** val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec psubX cO copp ceqb pop p' i' p = match p with - | Pc c -> PX ((popp copp p'), i', p) - | Pinj (j, q') -> - (match j with - | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> PX ((popp copp p'), i', (Pinj ( - (pdouble_minus_one j0), q'))) - | XH -> PX ((popp copp p'), i', q')) - | PX (p2, i, q') -> - (match zPminus i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') - -(** val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) - -let rec padd cO cadd ceqb p = function - | Pc c' -> paddC cadd p c' - | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p - | PX (p'0, i', q') -> - (match p with - | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX (p'0, i', - (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> PX (p'0, i', - (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0)) - q')) - | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) - | PX (p2, i, q0) -> - (match zPminus i i' with - | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i - (padd cO cadd ceqb q0 q') - | Zpos k -> - mkPX cO ceqb - (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0 - k p2) i (padd cO cadd ceqb q0 q'))) - -(** val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec psub cO cadd csub copp ceqb p = function - | Pc c' -> psubC csub p c' - | Pinj (j', q') -> - psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p - | PX (p'0, i', q') -> - (match p with - | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj - ((pdouble_minus_one j0), q0)) q')) - | XH -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb q0 q'))) - | PX (p2, i, q0) -> - (match zPminus i i' with - | Z0 -> - mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i - (psub cO cadd csub copp ceqb q0 q') - | Zpos k -> - mkPX cO ceqb - (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) - i' (psub cO cadd csub copp ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (psubX cO copp ceqb (fun x x0 -> - psub cO cadd csub copp ceqb x x0) p'0 k p2) i - (psub cO cadd csub copp ceqb q0 q'))) - -(** val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> - 'a1 pol **) - -let rec pmulC_aux cO cmul ceqb p c = - match p with - | Pc c' -> Pc (cmul c' c) - | Pinj (j, q0) -> - let p2 = pmulC_aux cO cmul ceqb q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | PX (p2, i, q0) -> - mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i - (pmulC_aux cO cmul ceqb q0 c) - -(** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol **) - -let pmulC cO cI cmul ceqb p c = - match ceqb c cO with - | True -> p0 cO - | False -> - (match ceqb c cI with - | True -> p - | False -> pmulC_aux cO cmul ceqb p c) - -(** val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) - -let rec pmulI cO cI cmul ceqb pmul0 q0 j = function - | Pc c -> - let p2 = pmulC cO cI cmul ceqb q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pmul0 q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pmul0 (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p', i', q') -> - (match j with - | XI j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') - | XO j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q') - | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' - (pmul0 q' q0)) - -(** val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) - -let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with - | Pc c -> pmulC cO cI cmul ceqb p c - | Pinj (j', q') -> - pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q' - j' p - | PX (p', i', q') -> - (match p with - | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> - mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' - (match j with - | XI j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' - | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj - ((pdouble_minus_one j0), q0)) q' - | XH -> pmul cO cI cadd cmul ceqb q0 q') - | PX (p2, i, q0) -> - padd cO cadd ceqb - (mkPX cO ceqb - (padd cO cadd ceqb - (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO)) - (pmul cO cI cadd cmul ceqb - (match q0 with - | Pc c -> q0 - | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' - (p0 cO)) - (mkPX cO ceqb - (pmulI cO cI cmul ceqb (fun x x0 -> - pmul cO cI cadd cmul ceqb x x0) q' XH p2) i - (pmul cO cI cadd cmul ceqb q0 q'))) - -type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n - -(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) - -let mk_X cO cI j = - mkPinj_pred j (mkX cO cI) - -(** val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 - pol **) - -let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function - | XI p3 -> - subst_l - (pmul cO cI cadd cmul ceqb - (ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) - | XO p3 -> - ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 - | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) - -(** val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) - -let ppow_N cO cI cadd cmul ceqb subst_l p = function - | N0 -> p1 cI - | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 - -(** val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) - -let rec norm_aux cO cI cadd cmul csub copp ceqb = function - | PEc c -> Pc c - | PEX j -> mk_X cO cI j - | PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) - | PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - | PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) - | PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 - -type 'a bFormula = - | TT - | FF - | X - | A of 'a - | Cj of 'a bFormula * 'a bFormula - | D of 'a bFormula * 'a bFormula - | N of 'a bFormula - | I of 'a bFormula * 'a bFormula - -type 'term' clause = 'term' list - -type 'term' cnf = 'term' clause list - -(** val tt : 'a1 cnf **) - -let tt = - Nil - -(** val ff : 'a1 cnf **) - -let ff = - Cons (Nil, Nil) - -(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **) - -let or_clause_cnf t0 f = - map (fun x -> app t0 x) f - -(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) - -let rec or_cnf f f' = - match f with - | Nil -> tt - | Cons (e, rst) -> app (or_cnf rst f') (or_clause_cnf e f') - -(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) - -let and_cnf f1 f2 = - app f1 f2 - -(** val xcnf : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) - -let rec xcnf normalise0 negate0 pol0 = function - | TT -> (match pol0 with - | True -> tt - | False -> ff) - | FF -> (match pol0 with - | True -> ff - | False -> tt) - | X -> ff - | A x -> (match pol0 with - | True -> normalise0 x - | False -> negate0 x) - | Cj (e1, e2) -> - (match pol0 with - | True -> - and_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - | False -> - or_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2)) - | D (e1, e2) -> - (match pol0 with - | True -> - or_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - | False -> - and_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2)) - | N e -> xcnf normalise0 negate0 (negb pol0) e - | I (e1, e2) -> - (match pol0 with - | True -> - or_cnf (xcnf normalise0 negate0 (negb pol0) e1) - (xcnf normalise0 negate0 pol0 e2) - | False -> - and_cnf (xcnf normalise0 negate0 (negb pol0) e1) - (xcnf normalise0 negate0 pol0 e2)) - -(** val cnf_checker : - ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) - -let rec cnf_checker checker f l = - match f with - | Nil -> True - | Cons (e, f0) -> - (match l with - | Nil -> False - | Cons (c, l0) -> - (match checker e c with - | True -> cnf_checker checker f0 l0 - | False -> False)) - -(** val tauto_checker : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 - bFormula -> 'a3 list -> bool **) - -let tauto_checker normalise0 negate0 checker f w = - cnf_checker checker (xcnf normalise0 negate0 True f) w - -type 'c pExprC = 'c pExpr - -type 'c polC = 'c pol - -type op1 = - | Equal - | NonEqual - | Strict - | NonStrict - -type 'c nFormula = ('c pExprC, op1) prod - -type monoidMember = nat list - -type 'c coneMember = - | S_In of nat - | S_Ideal of 'c pExprC * 'c coneMember - | S_Square of 'c pExprC - | S_Monoid of monoidMember - | S_Mult of 'c coneMember * 'c coneMember - | S_Add of 'c coneMember * 'c coneMember - | S_Pos of 'c - | S_Z - -(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **) - -let nformula_times f f' = - let Pair (p, op) = f in - let Pair (p', op') = f' in - Pair ((PEmul (p, p')), - (match op with - | Equal -> Equal - | NonEqual -> NonEqual - | Strict -> op' - | NonStrict -> NonStrict)) - -(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **) - -let nformula_plus f f' = - let Pair (p, op) = f in - let Pair (p', op') = f' in - Pair ((PEadd (p, p')), - (match op with - | Equal -> op' - | NonEqual -> NonEqual - | Strict -> Strict - | NonStrict -> (match op' with - | Strict -> Strict - | _ -> NonStrict))) - -(** val eval_monoid : - 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **) - -let rec eval_monoid cI l = function - | Nil -> PEc cI - | Cons (n0, ns0) -> PEmul - ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in - (match o with - | NonEqual -> q0 - | _ -> PEc cI)), (eval_monoid cI l ns0)) - -(** val eval_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 - nFormula list -> 'a1 coneMember -> 'a1 nFormula **) - -let rec eval_cone cO cI ceqb cleb l = function - | S_In n0 -> - let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in - (match o with - | NonEqual -> Pair ((PEc cO), Equal) - | _ -> nth n0 l (Pair ((PEc cO), Equal))) - | S_Ideal (p, cm') -> - let f = eval_cone cO cI ceqb cleb l cm' in - let Pair (q0, op) = f in - (match op with - | Equal -> Pair ((PEmul (q0, p)), Equal) - | _ -> f) - | S_Square p -> Pair ((PEmul (p, p)), NonStrict) - | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict) - | S_Mult (p, q0) -> - nformula_times (eval_cone cO cI ceqb cleb l p) - (eval_cone cO cI ceqb cleb l q0) - | S_Add (p, q0) -> - nformula_plus (eval_cone cO cI ceqb cleb l p) - (eval_cone cO cI ceqb cleb l q0) - | S_Pos c -> - (match match cleb cO c with - | True -> negb (ceqb cO c) - | False -> False with - | True -> Pair ((PEc c), Strict) - | False -> Pair ((PEc cO), Equal)) - | S_Z -> Pair ((PEc cO), Equal) - -(** val normalise_pexpr : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **) - -let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x = - norm_aux cO cI cplus ctimes cminus copp ceqb x - -(** val check_inconsistent : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula -> bool **) - -let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function - | Pair (e, op) -> - (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with - | Pc c -> - (match op with - | Equal -> negb (ceqb c cO) - | NonEqual -> False - | Strict -> cleb c cO - | NonStrict -> - (match cleb c cO with - | True -> negb (ceqb c cO) - | False -> False)) - | _ -> False) - -(** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list -> 'a1 coneMember -> bool **) - -let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm = - check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb - (eval_cone cO cI ceqb cleb l cm) - -type op2 = - | OpEq - | OpNEq - | OpLe - | OpGe - | OpLt - | OpGt - -type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC } - -(** val flhs : 'a1 formula -> 'a1 pExprC **) - -let flhs x = x.flhs - -(** val fop : 'a1 formula -> op2 **) - -let fop x = x.fop - -(** val frhs : 'a1 formula -> 'a1 pExprC **) - -let frhs x = x.frhs - -(** val xnormalise : 'a1 formula -> 'a1 nFormula list **) - -let xnormalise t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - (match o with - | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair - ((PEsub (rhs, lhs)), Strict)), Nil))) - | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) - | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil) - | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil) - | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) - | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)) - -(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **) - -let cnf_normalise t0 = - map (fun x -> Cons (x, Nil)) (xnormalise t0) - -(** val xnegate : 'a1 formula -> 'a1 nFormula list **) - -let xnegate t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - (match o with - | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) - | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair - ((PEsub (rhs, lhs)), Strict)), Nil))) - | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil) - | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) - | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil) - | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)) - -(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **) - -let cnf_negate t0 = - map (fun x -> Cons (x, Nil)) (xnegate t0) - -(** val simpl_expr : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **) - -let rec simpl_expr cI ceqb e = match e with - | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y)) - | PEmul (y, z0) -> - let y' = simpl_expr cI ceqb y in - (match y' with - | PEc c -> - (match ceqb c cI with - | True -> simpl_expr cI ceqb z0 - | False -> PEmul (y', (simpl_expr cI ceqb z0))) - | _ -> PEmul (y', (simpl_expr cI ceqb z0))) - | _ -> e - -(** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - coneMember -> 'a1 coneMember **) - -let simpl_cone cO cI ctimes ceqb e = match e with - | S_Square t0 -> - (match simpl_expr cI ceqb t0 with - | PEc c -> - (match ceqb cO c with - | True -> S_Z - | False -> S_Pos (ctimes c c)) - | _ -> S_Square (simpl_expr cI ceqb t0)) - | S_Mult (t1, t2) -> - (match t1 with - | S_Mult (x, x0) -> - (match x with - | S_Pos p2 -> - (match t2 with - | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0) - | S_Z -> S_Z - | _ -> e) - | _ -> - (match x0 with - | S_Pos p2 -> - (match t2 with - | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x) - | S_Z -> S_Z - | _ -> e) - | _ -> - (match t2 with - | S_Pos c -> - (match ceqb cI c with - | True -> t1 - | False -> S_Mult (t1, t2)) - | S_Z -> S_Z - | _ -> e))) - | S_Pos c -> - (match t2 with - | S_Mult (x, x0) -> - (match x with - | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0) - | _ -> - (match x0 with - | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x) - | _ -> - (match ceqb cI c with - | True -> t2 - | False -> S_Mult (t1, t2)))) - | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult - ((S_Pos c), z0))) - | S_Pos c0 -> S_Pos (ctimes c c0) - | S_Z -> S_Z - | _ -> - (match ceqb cI c with - | True -> t2 - | False -> S_Mult (t1, t2))) - | S_Z -> S_Z - | _ -> - (match t2 with - | S_Pos c -> - (match ceqb cI c with - | True -> t1 - | False -> S_Mult (t1, t2)) - | S_Z -> S_Z - | _ -> e)) - | S_Add (t1, t2) -> - (match t1 with - | S_Z -> t2 - | _ -> (match t2 with - | S_Z -> t1 - | _ -> S_Add (t1, t2))) - | _ -> e - -type q = { qnum : z; qden : positive } - -(** val qnum : q -> z **) - -let qnum x = x.qnum - -(** val qden : q -> positive **) - -let qden x = x.qden - -(** val qplus : q -> q -> q **) - -let qplus x y = - { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))); - qden = (pmult x.qden y.qden) } - -(** val qmult : q -> q -> q **) - -let qmult x y = - { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) } - -(** val qopp : q -> q **) - -let qopp x = - { qnum = (zopp x.qnum); qden = x.qden } - -(** val qminus : q -> q -> q **) - -let qminus x y = - qplus x (qopp y) - -type 'a t = - | Empty - | Leaf of 'a - | Node of 'a t * 'a * 'a t - -(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) - -let rec find default vm p = - match vm with - | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> - (match p with - | XI p2 -> find default r p2 - | XO p2 -> find default l p2 - | XH -> e) - -type zWitness = z coneMember - -(** val zWeakChecker : z nFormula list -> z coneMember -> bool **) - -let zWeakChecker x x0 = - check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool - zle_bool x x0 - -(** val xnormalise0 : z formula -> z nFormula list **) - -let xnormalise0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - (match o with - | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), - NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos - XH)))))), NonStrict)), Nil))) - | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) - | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), - NonStrict)), Nil) - | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))), - NonStrict)), Nil) - | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) - | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)) - -(** val normalise : z formula -> z nFormula cnf **) - -let normalise t0 = - map (fun x -> Cons (x, Nil)) (xnormalise0 t0) - -(** val xnegate0 : z formula -> z nFormula list **) - -let xnegate0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - (match o with - | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil) - | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), - NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos - XH)))))), NonStrict)), Nil))) - | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil) - | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil) - | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))), - NonStrict)), Nil) - | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))), - NonStrict)), Nil)) - -(** val negate : z formula -> z nFormula cnf **) - -let negate t0 = - map (fun x -> Cons (x, Nil)) (xnegate0 t0) - -(** val ceiling : z -> z -> z **) - -let ceiling a b = - let Pair (q0, r) = zdiv_eucl a b in - (match r with - | Z0 -> q0 - | _ -> zplus q0 (Zpos XH)) - -type proofTerm = - | RatProof of zWitness - | CutProof of z pExprC * q * zWitness * proofTerm - | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list - -(** val makeLb : z pExpr -> q -> z nFormula **) - -let makeLb v q0 = - let { qnum = n0; qden = d } = q0 in - Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict) - -(** val qceiling : q -> z **) - -let qceiling q0 = - let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d) - -(** val makeLbCut : z pExprC -> q -> z nFormula **) - -let makeLbCut v q0 = - Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict) - -(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **) - -let neg_nformula = function - | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o) - -(** val cutChecker : - z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **) - -let cutChecker l e lb pf = - match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with - | True -> Some (makeLbCut e lb) - | False -> None - -(** val zChecker : z nFormula list -> proofTerm -> bool **) - -let rec zChecker l = function - | RatProof pf0 -> zWeakChecker l pf0 - | CutProof (e, q0, pf0, rst) -> - (match cutChecker l e q0 pf0 with - | Some c -> zChecker (Cons (c, l)) rst - | None -> False) - | EnumProof (lb, e, ub, pf1, pf2, rst) -> - (match cutChecker l e lb pf1 with - | Some n0 -> - (match cutChecker l (PEopp e) (qopp ub) pf2 with - | Some n1 -> - let rec label pfs lb0 ub0 = - match pfs with - | Nil -> - (match z_gt_dec lb0 ub0 with - | Left -> True - | Right -> False) - | Cons (pf0, rsr) -> - (match zChecker (Cons ((Pair ((PEsub (e, (PEc - lb0))), Equal)), l)) pf0 with - | True -> label rsr (zplus lb0 (Zpos XH)) ub0 - | False -> False) - in label rst (qceiling lb) (zopp (qceiling (qopp ub))) - | None -> False) - | None -> False) - -(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **) - -let zTautoChecker f w = - tauto_checker normalise negate zChecker f w - -(** val map_cone : (nat -> nat) -> zWitness -> zWitness **) - -let rec map_cone f e = match e with - | S_In n0 -> S_In (f n0) - | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm)) - | S_Monoid l -> S_Monoid (map f l) - | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2)) - | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2)) - | _ -> e - -(** val indexes : zWitness -> nat list **) - -let rec indexes = function - | S_In n0 -> Cons (n0, Nil) - | S_Ideal (e0, cm) -> indexes cm - | S_Monoid l -> l - | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2) - | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2) - | _ -> Nil - -(** val n_of_Z : z -> n **) - -let n_of_Z = function - | Zpos p -> Npos p - | _ -> N0 - -(** val qeq_bool : q -> q -> bool **) - -let qeq_bool p q0 = - zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.qden)) - -(** val qle_bool : q -> q -> bool **) - -let qle_bool x y = - zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) - -type qWitness = q coneMember - -(** val qWeakChecker : q nFormula list -> q coneMember -> bool **) - -let qWeakChecker x x0 = - check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0 - -(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) - -let qTautoChecker f w = - tauto_checker (fun x -> cnf_normalise x) (fun x -> - cnf_negate x) qWeakChecker f w - diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli deleted file mode 100644 index f94f091e..00000000 --- a/contrib/micromega/micromega.mli +++ /dev/null @@ -1,398 +0,0 @@ -type __ = Obj.t - -type bool = - | True - | False - -val negb : bool -> bool - -type nat = - | O - | S of nat - -type 'a option = - | Some of 'a - | None - -type ('a, 'b) prod = - | Pair of 'a * 'b - -type comparison = - | Eq - | Lt - | Gt - -val compOpp : comparison -> comparison - -type sumbool = - | Left - | Right - -type 'a sumor = - | Inleft of 'a - | Inright - -type 'a list = - | Nil - | Cons of 'a * 'a list - -val app : 'a1 list -> 'a1 list -> 'a1 list - -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -type positive = - | XI of positive - | XO of positive - | XH - -val psucc : positive -> positive - -val pplus : positive -> positive -> positive - -val pplus_carry : positive -> positive -> positive - -val p_of_succ_nat : nat -> positive - -val pdouble_minus_one : positive -> positive - -type positive_mask = - | IsNul - | IsPos of positive - | IsNeg - -val pdouble_plus_one_mask : positive_mask -> positive_mask - -val pdouble_mask : positive_mask -> positive_mask - -val pdouble_minus_two : positive -> positive_mask - -val pminus_mask : positive -> positive -> positive_mask - -val pminus_mask_carry : positive -> positive -> positive_mask - -val pminus : positive -> positive -> positive - -val pmult : positive -> positive -> positive - -val pcompare : positive -> positive -> comparison -> comparison - -type n = - | N0 - | Npos of positive - -type z = - | Z0 - | Zpos of positive - | Zneg of positive - -val zdouble_plus_one : z -> z - -val zdouble_minus_one : z -> z - -val zdouble : z -> z - -val zPminus : positive -> positive -> z - -val zplus : z -> z -> z - -val zopp : z -> z - -val zminus : z -> z -> z - -val zmult : z -> z -> z - -val zcompare : z -> z -> comparison - -val dcompare_inf : comparison -> sumbool sumor - -val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - -val z_gt_dec : z -> z -> sumbool - -val zle_bool : z -> z -> bool - -val zge_bool : z -> z -> bool - -val zgt_bool : z -> z -> bool - -val zeq_bool : z -> z -> bool - -val n_of_nat : nat -> n - -val zdiv_eucl_POS : positive -> z -> (z, z) prod - -val zdiv_eucl : z -> z -> (z, z) prod - -type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol - -val p0 : 'a1 -> 'a1 pol - -val p1 : 'a1 -> 'a1 pol - -val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool - -val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol - -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol - -val mkX : 'a1 -> 'a1 -> 'a1 pol - -val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol - -val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol - -val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol - -val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol - -val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol - -val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> - 'a1 pol - -val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 - -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol - -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 - pol - -val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 - -> 'a1 pol - -val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> - 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol - -val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol - -type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n - -val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol - -val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol - -val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol - -val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol - -type 'a bFormula = - | TT - | FF - | X - | A of 'a - | Cj of 'a bFormula * 'a bFormula - | D of 'a bFormula * 'a bFormula - | N of 'a bFormula - | I of 'a bFormula * 'a bFormula - -type 'term' clause = 'term' list - -type 'term' cnf = 'term' clause list - -val tt : 'a1 cnf - -val ff : 'a1 cnf - -val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf - -val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf - -val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf - -val xcnf : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf - -val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool - -val tauto_checker : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 - bFormula -> 'a3 list -> bool - -type 'c pExprC = 'c pExpr - -type 'c polC = 'c pol - -type op1 = - | Equal - | NonEqual - | Strict - | NonStrict - -type 'c nFormula = ('c pExprC, op1) prod - -type monoidMember = nat list - -type 'c coneMember = - | S_In of nat - | S_Ideal of 'c pExprC * 'c coneMember - | S_Square of 'c pExprC - | S_Monoid of monoidMember - | S_Mult of 'c coneMember * 'c coneMember - | S_Add of 'c coneMember * 'c coneMember - | S_Pos of 'c - | S_Z - -val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula - -val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula - -val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC - -val eval_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula - list -> 'a1 coneMember -> 'a1 nFormula - -val normalise_pexpr : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC - -val check_inconsistent : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 - nFormula -> bool - -val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 - nFormula list -> 'a1 coneMember -> bool - -type op2 = - | OpEq - | OpNEq - | OpLe - | OpGe - | OpLt - | OpGt - -type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC } - -val flhs : 'a1 formula -> 'a1 pExprC - -val fop : 'a1 formula -> op2 - -val frhs : 'a1 formula -> 'a1 pExprC - -val xnormalise : 'a1 formula -> 'a1 nFormula list - -val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf - -val xnegate : 'a1 formula -> 'a1 nFormula list - -val cnf_negate : 'a1 formula -> 'a1 nFormula cnf - -val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC - -val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember - -> 'a1 coneMember - -type q = { qnum : z; qden : positive } - -val qnum : q -> z - -val qden : q -> positive - -val qplus : q -> q -> q - -val qmult : q -> q -> q - -val qopp : q -> q - -val qminus : q -> q -> q - -type 'a t = - | Empty - | Leaf of 'a - | Node of 'a t * 'a * 'a t - -val find : 'a1 -> 'a1 t -> positive -> 'a1 - -type zWitness = z coneMember - -val zWeakChecker : z nFormula list -> z coneMember -> bool - -val xnormalise0 : z formula -> z nFormula list - -val normalise : z formula -> z nFormula cnf - -val xnegate0 : z formula -> z nFormula list - -val negate : z formula -> z nFormula cnf - -val ceiling : z -> z -> z - -type proofTerm = - | RatProof of zWitness - | CutProof of z pExprC * q * zWitness * proofTerm - | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list - -val makeLb : z pExpr -> q -> z nFormula - -val qceiling : q -> z - -val makeLbCut : z pExprC -> q -> z nFormula - -val neg_nformula : z nFormula -> (z pExpr, op1) prod - -val cutChecker : - z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option - -val zChecker : z nFormula list -> proofTerm -> bool - -val zTautoChecker : z formula bFormula -> proofTerm list -> bool - -val map_cone : (nat -> nat) -> zWitness -> zWitness - -val indexes : zWitness -> nat list - -val n_of_Z : z -> n - -val qeq_bool : q -> q -> bool - -val qle_bool : q -> q -> bool - -type qWitness = q coneMember - -val qWeakChecker : q nFormula list -> q coneMember -> bool - -val qTautoChecker : q formula bFormula -> qWitness list -> bool - diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml deleted file mode 100644 index 2473608f..00000000 --- a/contrib/micromega/mutils.ml +++ /dev/null @@ -1,305 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -let debug = false - -let fst' (Micromega.Pair(x,y)) = x -let snd' (Micromega.Pair(x,y)) = y - -let rec try_any l x = - match l with - | [] -> None - | (f,s)::l -> match f x with - | None -> try_any l x - | x -> x - -let list_try_find f = - let rec try_find_f = function - | [] -> failwith "try_find" - | h::t -> try f h with Failure _ -> try_find_f t - in - try_find_f - -let rec list_fold_right_elements f l = - let rec aux = function - | [] -> invalid_arg "list_fold_right_elements" - | [x] -> x - | x::l -> f x (aux l) in - aux l - -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l,pred m) - in - interval_n ([],m) - -open Num -open Big_int - -let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - - -let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r - -let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i - -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l - -let rec rec_gcd_list c l = - match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let rec gcd_list l = - let res = rec_gcd_list zero_big_int l in - if compare_big_int res zero_big_int = 0 - then unit_big_int else res - - - -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l - -(* Nasty reordering of lists - useful to trim certificate down *) -let mapi f l = - let rec xmapi i l = - match l with - | [] -> [] - | e::l -> (f e i)::(xmapi (i+1) l) in - xmapi 0 l - - -let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) - -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) - -let assoc_pos_assoc l = - let rec xpos i l = - match l with - | [] -> [] - | (x,l) ::rst -> let (l',j) = assoc_pos i l in - (x,l')::(xpos j rst) in - xpos 0 l - -let filter_pos f l = - (* Could sort ... take care of duplicates... *) - let rec xfilter l = - match l with - | [] -> [] - | (x,e)::l -> - if List.exists (fun ee -> List.mem ee f) (List.map snd e) - then (x,e)::(xfilter l) - else xfilter l in - xfilter l - -let select_pos lpos l = - let rec xselect i lpos l = - match lpos with - | [] -> [] - | j::rpos -> - match l with - | [] -> failwith "select_pos" - | e::l -> - if i = j - then e:: (xselect (i+1) rpos l) - else xselect (i+1) lpos l in - xselect 0 lpos l - - -module CoqToCaml = -struct - open Micromega - - let rec nat = function - | O -> 0 - | S n -> (nat n) + 1 - - - let rec positive p = - match p with - | XH -> 1 - | XI p -> 1+ 2*(positive p) - | XO p -> 2*(positive p) - - - let n nt = - match nt with - | N0 -> 0 - | Npos p -> positive p - - - let rec index i = (* Swap left-right ? *) - match i with - | XH -> 1 - | XI i -> 1+(2*(index i)) - | XO i -> 2*(index i) - - - let z x = - match x with - | Z0 -> 0 - | Zpos p -> (positive p) - | Zneg p -> - (positive p) - - open Big_int - - let rec positive_big_int p = - match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> (mult_int_big_int 2 (positive_big_int p)) - - - let z_big_int x = - match x with - | Z0 -> zero_big_int - | Zpos p -> (positive_big_int p) - | Zneg p -> minus_big_int (positive_big_int p) - - - let num x = Num.Big_int (z_big_int x) - - let rec list elt l = - match l with - | Nil -> [] - | Cons(e,l) -> (elt e)::(list elt l) - - let q_to_num {qnum = x ; qden = y} = - Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - -end - - -module CamlToCoq = -struct - open Micromega - - let rec nat = function - | 0 -> O - | n -> S (nat (n-1)) - - - let rec positive n = - if n=1 then XH - else if n land 1 = 1 then XI (positive (n lsr 1)) - else XO (positive (n lsr 1)) - - let n nt = - if nt < 0 - then assert false - else if nt = 0 then N0 - else Npos (positive nt) - - - - - - let rec index n = - if n=1 then XH - else if n land 1 = 1 then XI (index (n lsr 1)) - else XO (index (n lsr 1)) - - - let idx n = - (*a.k.a path_of_int *) - (* returns the list of digits of n in reverse order with - initial 1 removed *) - let rec digits_of_int n = - if n=1 then [] - else (n mod 2 = 1)::(digits_of_int (n lsr 1)) - in - List.fold_right - (fun b c -> (if b then XI c else XO c)) - (List.rev (digits_of_int n)) - (XH) - - - - let z x = - match compare x 0 with - | 0 -> Z0 - | 1 -> Zpos (positive x) - | _ -> (* this should be -1 *) - Zneg (positive (-x)) - - open Big_int - - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = - if eq_big_int n unit_big_int then XH - else - let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m - then XI (_pos q) - else XO (_pos q) in - _pos n - - let bigint x = - match sign_big_int x with - | 0 -> Z0 - | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) - - let q n = - {Micromega.qnum = bigint (numerator n) ; - Micromega.qden = positive_big_int (denominator n)} - - - let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil - -end - -module Cmp = -struct - - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> - let cmp = f () in - if cmp = 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> - let c = cmp e1 e2 in - if c = 0 then compare_list cmp l1 l2 else c - - let hash_list hash l = - let rec _hash_list l h = - match l with - | [] -> h lxor (Hashtbl.hash []) - | e::l -> _hash_list l ((hash e) lxor h) in - - _hash_list l 0 -end diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml deleted file mode 100644 index e3d72ed9..00000000 --- a/contrib/micromega/sos.ml +++ /dev/null @@ -1,1919 +0,0 @@ -(* ========================================================================= *) -(* - This code originates from John Harrison's HOL LIGHT 2.20 *) -(* (see file LICENSE.sos for license, copyright and disclaimer) *) -(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *) -(* independent bits *) -(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) -(* - Addition of a csdp cache by the Coq development team *) -(* ========================================================================= *) - -(* ========================================================================= *) -(* Nonlinear universal reals procedure using SOS decomposition. *) -(* ========================================================================= *) - -open Num;; -open List;; - -let debugging = ref false;; - -exception Sanity;; - -exception Unsolvable;; - -(* ------------------------------------------------------------------------- *) -(* Comparisons that are reflexive on NaN and also short-circuiting. *) -(* ------------------------------------------------------------------------- *) - -let (=?) = fun x y -> Pervasives.compare x y = 0;; -let (<?) = fun x y -> Pervasives.compare x y < 0;; -let (<=?) = fun x y -> Pervasives.compare x y <= 0;; -let (>?) = fun x y -> Pervasives.compare x y > 0;; -let (>=?) = fun x y -> Pervasives.compare x y >= 0;; - -(* ------------------------------------------------------------------------- *) -(* Combinators. *) -(* ------------------------------------------------------------------------- *) - -let (o) = fun f g x -> f(g x);; - -(* ------------------------------------------------------------------------- *) -(* Some useful functions on "num" type. *) -(* ------------------------------------------------------------------------- *) - - -let num_0 = Int 0 -and num_1 = Int 1 -and num_2 = Int 2 -and num_10 = Int 10;; - -let pow2 n = power_num num_2 (Int n);; -let pow10 n = power_num num_10 (Int n);; - -let numdom r = - let r' = Ratio.normalize_ratio (ratio_of_num r) in - num_of_big_int(Ratio.numerator_ratio r'), - num_of_big_int(Ratio.denominator_ratio r');; - -let numerator = (o) fst numdom -and denominator = (o) snd numdom;; - -let gcd_num n1 n2 = - num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));; - -let lcm_num x y = - if x =/ num_0 & y =/ num_0 then num_0 - else abs_num((x */ y) // gcd_num x y);; - - -(* ------------------------------------------------------------------------- *) -(* List basics. *) -(* ------------------------------------------------------------------------- *) - -let rec el n l = - if n = 0 then hd l else el (n - 1) (tl l);; - - -(* ------------------------------------------------------------------------- *) -(* Various versions of list iteration. *) -(* ------------------------------------------------------------------------- *) - -let rec itlist f l b = - match l with - [] -> b - | (h::t) -> f h (itlist f t b);; - -let rec end_itlist f l = - match l with - [] -> failwith "end_itlist" - | [x] -> x - | (h::t) -> f h (end_itlist f t);; - -let rec itlist2 f l1 l2 b = - match (l1,l2) with - ([],[]) -> b - | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) - | _ -> failwith "itlist2";; - -(* ------------------------------------------------------------------------- *) -(* All pairs arising from applying a function over two lists. *) -(* ------------------------------------------------------------------------- *) - -let rec allpairs f l1 l2 = - match l1 with - h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) - | [] -> [];; - -(* ------------------------------------------------------------------------- *) -(* String operations (surely there is a better way...) *) -(* ------------------------------------------------------------------------- *) - -let implode l = itlist (^) l "";; - -let explode s = - let rec exap n l = - if n < 0 then l else - exap (n - 1) ((String.sub s n 1)::l) in - exap (String.length s - 1) [];; - - -(* ------------------------------------------------------------------------- *) -(* Attempting function or predicate applications. *) -(* ------------------------------------------------------------------------- *) - -let can f x = try (f x; true) with Failure _ -> false;; - - -(* ------------------------------------------------------------------------- *) -(* Repetition of a function. *) -(* ------------------------------------------------------------------------- *) - -let rec funpow n f x = - if n < 1 then x else funpow (n-1) f (f x);; - - -(* ------------------------------------------------------------------------- *) -(* term?? *) -(* ------------------------------------------------------------------------- *) - -type vname = string;; - -type term = -| Zero -| Const of Num.num -| Var of vname -| Inv of term -| Opp of term -| Add of (term * term) -| Sub of (term * term) -| Mul of (term * term) -| Div of (term * term) -| Pow of (term * int);; - - -(* ------------------------------------------------------------------------- *) -(* Data structure for Positivstellensatz refutations. *) -(* ------------------------------------------------------------------------- *) - -type positivstellensatz = - Axiom_eq of int - | Axiom_le of int - | Axiom_lt of int - | Rational_eq of num - | Rational_le of num - | Rational_lt of num - | Square of term - | Monoid of int list - | Eqmul of term * positivstellensatz - | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz;; - - - -(* ------------------------------------------------------------------------- *) -(* Replication and sequences. *) -(* ------------------------------------------------------------------------- *) - -let rec replicate x n = - if n < 1 then [] - else x::(replicate x (n - 1));; - -let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; - -(* ------------------------------------------------------------------------- *) -(* Various useful list operations. *) -(* ------------------------------------------------------------------------- *) - -let rec forall p l = - match l with - [] -> true - | h::t -> p(h) & forall p t;; - -let rec tryfind f l = - match l with - [] -> failwith "tryfind" - | (h::t) -> try f h with Failure _ -> tryfind f t;; - -let index x = - let rec ind n l = - match l with - [] -> failwith "index" - | (h::t) -> if x =? h then n else ind (n + 1) t in - ind 0;; - -(* ------------------------------------------------------------------------- *) -(* "Set" operations on lists. *) -(* ------------------------------------------------------------------------- *) - -let rec mem x lis = - match lis with - [] -> false - | (h::t) -> x =? h or mem x t;; - -let insert x l = - if mem x l then l else x::l;; - -let union l1 l2 = itlist insert l1 l2;; - -let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;; - -(* ------------------------------------------------------------------------- *) -(* Merging and bottom-up mergesort. *) -(* ------------------------------------------------------------------------- *) - -let rec merge ord l1 l2 = - match l1 with - [] -> l2 - | h1::t1 -> match l2 with - [] -> l1 - | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) - else h2::(merge ord l1 t2);; - - -(* ------------------------------------------------------------------------- *) -(* Common measure predicates to use with "sort". *) -(* ------------------------------------------------------------------------- *) - -let increasing f x y = f x <? f y;; - -let decreasing f x y = f x >? f y;; - -(* ------------------------------------------------------------------------- *) -(* Zipping, unzipping etc. *) -(* ------------------------------------------------------------------------- *) - -let rec zip l1 l2 = - match (l1,l2) with - ([],[]) -> [] - | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) - | _ -> failwith "zip";; - -let rec unzip = - function [] -> [],[] - | ((a,b)::rest) -> let alist,blist = unzip rest in - (a::alist,b::blist);; - -(* ------------------------------------------------------------------------- *) -(* Iterating functions over lists. *) -(* ------------------------------------------------------------------------- *) - -let rec do_list f l = - match l with - [] -> () - | (h::t) -> (f h; do_list f t);; - -(* ------------------------------------------------------------------------- *) -(* Sorting. *) -(* ------------------------------------------------------------------------- *) - -let rec sort cmp lis = - match lis with - [] -> [] - | piv::rest -> - let r,l = partition (cmp piv) rest in - (sort cmp l) @ (piv::(sort cmp r));; - -(* ------------------------------------------------------------------------- *) -(* Removing adjacent (NB!) equal elements from list. *) -(* ------------------------------------------------------------------------- *) - -let rec uniq l = - match l with - x::(y::_ as t) -> let t' = uniq t in - if x =? y then t' else - if t'==t then l else x::t' - | _ -> l;; - -(* ------------------------------------------------------------------------- *) -(* Convert list into set by eliminating duplicates. *) -(* ------------------------------------------------------------------------- *) - -let setify s = uniq (sort (<=?) s);; - -(* ------------------------------------------------------------------------- *) -(* Polymorphic finite partial functions via Patricia trees. *) -(* *) -(* The point of this strange representation is that it is canonical (equal *) -(* functions have the same encoding) yet reasonably efficient on average. *) -(* *) -(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) -(* ------------------------------------------------------------------------- *) - -type ('a,'b)func = - Empty - | Leaf of int * ('a*'b)list - | Branch of int * int * ('a,'b)func * ('a,'b)func;; - -(* ------------------------------------------------------------------------- *) -(* Undefined function. *) -(* ------------------------------------------------------------------------- *) - -let undefined = Empty;; - -(* ------------------------------------------------------------------------- *) -(* In case of equality comparison worries, better use this. *) -(* ------------------------------------------------------------------------- *) - -let is_undefined f = - match f with - Empty -> true - | _ -> false;; - -(* ------------------------------------------------------------------------- *) -(* Operation analagous to "map" for lists. *) -(* ------------------------------------------------------------------------- *) - -let mapf = - let rec map_list f l = - match l with - [] -> [] - | (x,y)::t -> (x,f(y))::(map_list f t) in - let rec mapf f t = - match t with - Empty -> Empty - | Leaf(h,l) -> Leaf(h,map_list f l) - | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in - mapf;; - -(* ------------------------------------------------------------------------- *) -(* Operations analogous to "fold" for lists. *) -(* ------------------------------------------------------------------------- *) - -let foldl = - let rec foldl_list f a l = - match l with - [] -> a - | (x,y)::t -> foldl_list f (f a x y) t in - let rec foldl f a t = - match t with - Empty -> a - | Leaf(h,l) -> foldl_list f a l - | Branch(p,b,l,r) -> foldl f (foldl f a l) r in - foldl;; - -let foldr = - let rec foldr_list f l a = - match l with - [] -> a - | (x,y)::t -> f x y (foldr_list f t a) in - let rec foldr f t a = - match t with - Empty -> a - | Leaf(h,l) -> foldr_list f l a - | Branch(p,b,l,r) -> foldr f l (foldr f r a) in - foldr;; - -(* ------------------------------------------------------------------------- *) -(* Redefinition and combination. *) -(* ------------------------------------------------------------------------- *) - -let (|->),combine = - let ldb x y = let z = x lxor y in z land (-z) in - let newbranch p1 t1 p2 t2 = - let b = ldb p1 p2 in - let p = p1 land (b - 1) in - if p1 land b = 0 then Branch(p,b,t1,t2) - else Branch(p,b,t2,t1) in - let rec define_list (x,y as xy) l = - match l with - (a,b as ab)::t -> - if x =? a then xy::t - else if x <? a then xy::l - else ab::(define_list xy t) - | [] -> [xy] - and combine_list op z l1 l2 = - match (l1,l2) with - [],_ -> l2 - | _,[] -> l1 - | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> - if x1 <? x2 then xy1::(combine_list op z t1 l2) - else if x2 <? x1 then xy2::(combine_list op z l1 t2) else - let y = op y1 y2 and l = combine_list op z t1 t2 in - if z(y) then l else (x1,y)::l in - let (|->) x y = - let k = Hashtbl.hash x in - let rec upd t = - match t with - Empty -> Leaf (k,[x,y]) - | Leaf(h,l) -> - if h = k then Leaf(h,define_list (x,y) l) - else newbranch h t k (Leaf(k,[x,y])) - | Branch(p,b,l,r) -> - if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) - else if k land b = 0 then Branch(p,b,upd l,r) - else Branch(p,b,l,upd r) in - upd in - let rec combine op z t1 t2 = - match (t1,t2) with - Empty,_ -> t2 - | _,Empty -> t1 - | Leaf(h1,l1),Leaf(h2,l2) -> - if h1 = h2 then - let l = combine_list op z l1 l2 in - if l = [] then Empty else Leaf(h1,l) - else newbranch h1 t1 h2 t2 - | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) | - (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> - if k land (b - 1) = p then - if k land b = 0 then - let l' = combine op z lf l in - if is_undefined l' then r else Branch(p,b,l',r) - else - let r' = combine op z lf r in - if is_undefined r' then l else Branch(p,b,l,r') - else - newbranch k lf p br - | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> - if b1 < b2 then - if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 - else if p2 land b1 = 0 then - let l = combine op z l1 t2 in - if is_undefined l then r1 else Branch(p1,b1,l,r1) - else - let r = combine op z r1 t2 in - if is_undefined r then l1 else Branch(p1,b1,l1,r) - else if b2 < b1 then - if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 - else if p1 land b2 = 0 then - let l = combine op z t1 l2 in - if is_undefined l then r2 else Branch(p2,b2,l,r2) - else - let r = combine op z t1 r2 in - if is_undefined r then l2 else Branch(p2,b2,l2,r) - else if p1 = p2 then - let l = combine op z l1 l2 and r = combine op z r1 r2 in - if is_undefined l then r - else if is_undefined r then l else Branch(p1,b1,l,r) - else - newbranch p1 t1 p2 t2 in - (|->),combine;; - -(* ------------------------------------------------------------------------- *) -(* Special case of point function. *) -(* ------------------------------------------------------------------------- *) - -let (|=>) = fun x y -> (x |-> y) undefined;; - - -(* ------------------------------------------------------------------------- *) -(* Grab an arbitrary element. *) -(* ------------------------------------------------------------------------- *) - -let rec choose t = - match t with - Empty -> failwith "choose: completely undefined function" - | Leaf(h,l) -> hd l - | Branch(b,p,t1,t2) -> choose t1;; - -(* ------------------------------------------------------------------------- *) -(* Application. *) -(* ------------------------------------------------------------------------- *) - -let applyd = - let rec apply_listd l d x = - match l with - (a,b)::t -> if x =? a then b - else if x >? a then apply_listd t d x else d x - | [] -> d x in - fun f d x -> - let k = Hashtbl.hash x in - let rec look t = - match t with - Leaf(h,l) when h = k -> apply_listd l d x - | Branch(p,b,l,r) -> look (if k land b = 0 then l else r) - | _ -> d x in - look f;; - -let apply f = applyd f (fun x -> failwith "apply");; - -let tryapplyd f a d = applyd f (fun x -> d) a;; - -let defined f x = try apply f x; true with Failure _ -> false;; - -(* ------------------------------------------------------------------------- *) -(* Undefinition. *) -(* ------------------------------------------------------------------------- *) - -let undefine = - let rec undefine_list x l = - match l with - (a,b as ab)::t -> - if x =? a then t - else if x <? a then l else - let t' = undefine_list x t in - if t' == t then l else ab::t' - | [] -> [] in - fun x -> - let k = Hashtbl.hash x in - let rec und t = - match t with - Leaf(h,l) when h = k -> - let l' = undefine_list x l in - if l' == l then t - else if l' = [] then Empty - else Leaf(h,l') - | Branch(p,b,l,r) when k land (b - 1) = p -> - if k land b = 0 then - let l' = und l in - if l' == l then t - else if is_undefined l' then r - else Branch(p,b,l',r) - else - let r' = und r in - if r' == r then t - else if is_undefined r' then l - else Branch(p,b,l,r') - | _ -> t in - und;; - - -(* ------------------------------------------------------------------------- *) -(* Mapping to sorted-list representation of the graph, domain and range. *) -(* ------------------------------------------------------------------------- *) - -let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; - -let dom f = setify(foldl (fun a x y -> x::a) [] f);; - -let ran f = setify(foldl (fun a x y -> y::a) [] f);; - -(* ------------------------------------------------------------------------- *) -(* Turn a rational into a decimal string with d sig digits. *) -(* ------------------------------------------------------------------------- *) - -let decimalize = - let rec normalize y = - if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1 - else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1 - else 0 in - fun d x -> - if x =/ Int 0 then "0.0" else - let y = abs_num x in - let e = normalize y in - let z = pow10(-e) */ y +/ Int 1 in - let k = round_num(pow10 d */ z) in - (if x </ Int 0 then "-0." else "0.") ^ - implode(tl(explode(string_of_num k))) ^ - (if e = 0 then "" else "e"^string_of_int e);; - - -(* ------------------------------------------------------------------------- *) -(* Iterations over numbers, and lists indexed by numbers. *) -(* ------------------------------------------------------------------------- *) - -let rec itern k l f a = - match l with - [] -> a - | h::t -> itern (k + 1) t f (f h k a);; - -let rec iter (m,n) f a = - if n < m then a - else iter (m+1,n) f (f m a);; - -(* ------------------------------------------------------------------------- *) -(* The main types. *) -(* ------------------------------------------------------------------------- *) - -type vector = int*(int,num)func;; - -type matrix = (int*int)*(int*int,num)func;; - -type monomial = (vname,int)func;; - -type poly = (monomial,num)func;; - -(* ------------------------------------------------------------------------- *) -(* Assignment avoiding zeros. *) -(* ------------------------------------------------------------------------- *) - -let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;; - -(* ------------------------------------------------------------------------- *) -(* This can be generic. *) -(* ------------------------------------------------------------------------- *) - -let element (d,v) i = tryapplyd v i (Int 0);; - -let mapa f (d,v) = - d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;; - -let is_zero (d,v) = - match v with - Empty -> true - | _ -> false;; - -(* ------------------------------------------------------------------------- *) -(* Vectors. Conventionally indexed 1..n. *) -(* ------------------------------------------------------------------------- *) - -let vector_0 n = (n,undefined:vector);; - -let dim (v:vector) = fst v;; - -let vector_const c n = - if c =/ Int 0 then vector_0 n - else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; - -let vector_1 = vector_const (Int 1);; - -let vector_cmul c (v:vector) = - let n = dim v in - if c =/ Int 0 then vector_0 n - else n,mapf (fun x -> c */ x) (snd v);; - -let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);; - -let vector_add (v1:vector) (v2:vector) = - let m = dim v1 and n = dim v2 in - if m <> n then failwith "vector_add: incompatible dimensions" else - (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);; - -let vector_sub v1 v2 = vector_add v1 (vector_neg v2);; - -let vector_of_list l = - let n = length l in - (n,itlist2 (|->) (1--n) l undefined :vector);; - -(* ------------------------------------------------------------------------- *) -(* Matrices; again rows and columns indexed from 1. *) -(* ------------------------------------------------------------------------- *) - -let matrix_0 (m,n) = ((m,n),undefined:matrix);; - -let dimensions (m:matrix) = fst m;; - -let matrix_const c (m,n as mn) = - if m <> n then failwith "matrix_const: needs to be square" - else if c =/ Int 0 then matrix_0 mn - else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);; - -let matrix_1 = matrix_const (Int 1);; - -let matrix_cmul c (m:matrix) = - let (i,j) = dimensions m in - if c =/ Int 0 then matrix_0 (i,j) - else (i,j),mapf (fun x -> c */ x) (snd m);; - -let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);; - -let matrix_add (m1:matrix) (m2:matrix) = - let d1 = dimensions m1 and d2 = dimensions m2 in - if d1 <> d2 then failwith "matrix_add: incompatible dimensions" - else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);; - -let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);; - -let row k (m:matrix) = - let i,j = dimensions m in - (j, - foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m) - : vector);; - -let column k (m:matrix) = - let i,j = dimensions m in - (i, - foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m) - : vector);; - -let transp (m:matrix) = - let i,j = dimensions m in - ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);; - -let diagonal (v:vector) = - let n = dim v in - ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);; - -let matrix_of_list l = - let m = length l in - if m = 0 then matrix_0 (0,0) else - let n = length (hd l) in - (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;; - -(* ------------------------------------------------------------------------- *) -(* Monomials. *) -(* ------------------------------------------------------------------------- *) - -let monomial_eval assig (m:monomial) = - foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) - (Int 1) m;; - -let monomial_1 = (undefined:monomial);; - -let monomial_var x = (x |=> 1 :monomial);; - -let (monomial_mul:monomial->monomial->monomial) = - combine (+) (fun x -> false);; - -let monomial_pow (m:monomial) k = - if k = 0 then monomial_1 - else mapf (fun x -> k * x) m;; - -let monomial_divides (m1:monomial) (m2:monomial) = - foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;; - -let monomial_div (m1:monomial) (m2:monomial) = - let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in - if foldl (fun a x k -> k >= 0 & a) true m then m - else failwith "monomial_div: non-divisible";; - -let monomial_degree x (m:monomial) = tryapplyd m x 0;; - -let monomial_lcm (m1:monomial) (m2:monomial) = - (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2)) - (union (dom m1) (dom m2)) undefined :monomial);; - -let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;; - -let monomial_variables m = dom m;; - -(* ------------------------------------------------------------------------- *) -(* Polynomials. *) -(* ------------------------------------------------------------------------- *) - -let eval assig (p:poly) = - foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; - -let poly_0 = (undefined:poly);; - -let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;; - -let poly_var x = ((monomial_var x) |=> Int 1 :poly);; - -let poly_const c = - if c =/ Int 0 then poly_0 else (monomial_1 |=> c);; - -let poly_cmul c (p:poly) = - if c =/ Int 0 then poly_0 - else mapf (fun x -> c */ x) p;; - -let poly_neg (p:poly) = (mapf minus_num p :poly);; - -let poly_add (p1:poly) (p2:poly) = - (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);; - -let poly_sub p1 p2 = poly_add p1 (poly_neg p2);; - -let poly_cmmul (c,m) (p:poly) = - if c =/ Int 0 then poly_0 - else if m = monomial_1 then mapf (fun d -> c */ d) p - else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;; - -let poly_mul (p1:poly) (p2:poly) = - foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;; - -let poly_div (p1:poly) (p2:poly) = - if not(poly_isconst p2) then failwith "poly_div: non-constant" else - let c = eval undefined p2 in - if c =/ Int 0 then failwith "poly_div: division by zero" - else poly_cmul (Int 1 // c) p1;; - -let poly_square p = poly_mul p p;; - -let rec poly_pow p k = - if k = 0 then poly_const (Int 1) - else if k = 1 then p - else let q = poly_square(poly_pow p (k / 2)) in - if k mod 2 = 1 then poly_mul p q else q;; - -let poly_exp p1 p2 = - if not(poly_isconst p2) then failwith "poly_exp: not a constant" else - poly_pow p1 (Num.int_of_num (eval undefined p2));; - -let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;; - -let multidegree (p:poly) = - foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;; - -let poly_variables (p:poly) = - foldr (fun m c -> union (monomial_variables m)) p [];; - -(* ------------------------------------------------------------------------- *) -(* Order monomials for human presentation. *) -(* ------------------------------------------------------------------------- *) - -let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or (x1 = x2 & k1 > k2);; - -let humanorder_monomial = - let rec ord l1 l2 = match (l1,l2) with - _,[] -> true - | [],_ -> false - | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or (h1 = h2 & ord t1 t2) in - fun m1 m2 -> m1 = m2 or - ord (sort humanorder_varpow (graph m1)) - (sort humanorder_varpow (graph m2));; - -(* ------------------------------------------------------------------------- *) -(* Conversions to strings. *) -(* ------------------------------------------------------------------------- *) - -let string_of_vector min_size max_size (v:vector) = - let n_raw = dim v in - if n_raw = 0 then "[]" else - let n = max min_size (min n_raw max_size) in - let xs = map ((o) string_of_num (element v)) (1--n) in - "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^ - (if n_raw > max_size then ", ...]" else "]");; - -let string_of_matrix max_size (m:matrix) = - let i_raw,j_raw = dimensions m in - let i = min max_size i_raw and j = min max_size j_raw in - let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in - "["^end_itlist(fun s t -> s^";\n "^t) rstr ^ - (if j > max_size then "\n ...]" else "]");; - -let string_of_vname (v:vname): string = (v: string);; - -let rec string_of_term t = - match t with - Opp t1 -> "(- " ^ string_of_term t1 ^ ")" -| Add (t1, t2) -> - "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" -| Sub (t1, t2) -> - "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" -| Mul (t1, t2) -> - "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" -| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" -| Div (t1, t2) -> - "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" -| Pow (t1, n1) -> - "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" -| Zero -> "0" -| Var v -> "x" ^ (string_of_vname v) -| Const x -> string_of_num x;; - - -let string_of_varpow x k = - if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;; - -let string_of_monomial m = - if m = monomial_1 then "1" else - let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) - (sort humanorder_varpow (graph m)) [] in - end_itlist (fun s t -> s^"*"^t) vps;; - -let string_of_cmonomial (c,m) = - if m = monomial_1 then string_of_num c - else if c =/ Int 1 then string_of_monomial m - else string_of_num c ^ "*" ^ string_of_monomial m;; - -let string_of_poly (p:poly) = - if p = poly_0 then "<<0>>" else - let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in - let s = - List.fold_left (fun a (m,c) -> - if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m) - else a ^ " + " ^ string_of_cmonomial(c,m)) - "" cms in - let s1 = String.sub s 0 3 - and s2 = String.sub s 3 (String.length s - 3) in - "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";; - -(* ------------------------------------------------------------------------- *) -(* Printers. *) -(* ------------------------------------------------------------------------- *) - -let print_vector v = Format.print_string(string_of_vector 0 20 v);; - -let print_matrix m = Format.print_string(string_of_matrix 20 m);; - -let print_monomial m = Format.print_string(string_of_monomial m);; - -let print_poly m = Format.print_string(string_of_poly m);; - -(* -#install_printer print_vector;; -#install_printer print_matrix;; -#install_printer print_monomial;; -#install_printer print_poly;; -*) - -(* ------------------------------------------------------------------------- *) -(* Conversion from term. *) -(* ------------------------------------------------------------------------- *) - -let rec poly_of_term t = match t with - Zero -> poly_0 -| Const n -> poly_const n -| Var x -> poly_var x -| Opp t1 -> poly_neg (poly_of_term t1) -| Inv t1 -> - let p = poly_of_term t1 in - if poly_isconst p then poly_const(Int 1 // eval undefined p) - else failwith "poly_of_term: inverse of non-constant polyomial" -| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) -| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) -| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) -| Div (l, r) -> - let p = poly_of_term l and q = poly_of_term r in - if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p - else failwith "poly_of_term: division by non-constant polynomial" -| Pow (t, n) -> - poly_pow (poly_of_term t) n;; - -(* ------------------------------------------------------------------------- *) -(* String of vector (just a list of space-separated numbers). *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_vector (v:vector) = - let n = dim v in - let strs = map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; - -(* ------------------------------------------------------------------------- *) -(* String for block diagonal matrix numbered k. *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_blockdiagonal k m = - let pfx = string_of_int k ^" " in - let ents = - foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in - let entss = sort (increasing fst) ents in - itlist (fun ((b,i,j),c) a -> - pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; - -(* ------------------------------------------------------------------------- *) -(* String for a matrix numbered k, in SDPA sparse format. *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_matrix k (m:matrix) = - let pfx = string_of_int k ^ " 1 " in - let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) - (snd m) [] in - let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> - pfx ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; - -(* ------------------------------------------------------------------------- *) -(* String in SDPA sparse format for standard SDP problem: *) -(* *) -(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *) -(* Minimize obj_1 * v_1 + ... obj_m * v_m *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_problem comment obj mats = - let m = length mats - 1 - and n,_ = dimensions (hd mats) in - "\"" ^ comment ^ "\"\n" ^ - string_of_int m ^ "\n" ^ - "1\n" ^ - string_of_int n ^ "\n" ^ - sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) - (1--length mats) mats "";; - -(* ------------------------------------------------------------------------- *) -(* More parser basics. *) -(* ------------------------------------------------------------------------- *) - -exception Noparse;; - - -let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = - let charcode s = Char.code(String.get s 0) in - let spaces = " \t\n\r" - and separators = ",;" - and brackets = "()[]{}" - and symbs = "\\!@#$%^&*-+|\\<=>/?~.:" - and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" - and nums = "0123456789" in - let allchars = spaces^separators^brackets^symbs^alphas^nums in - let csetsize = itlist ((o) max charcode) (explode allchars) 256 in - let ctable = Array.make csetsize 0 in - do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); - do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); - do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); - do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); - do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); - do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); - let isspace c = Array.get ctable (charcode c) = 1 - and issep c = Array.get ctable (charcode c) = 2 - and isbra c = Array.get ctable (charcode c) = 4 - and issymb c = Array.get ctable (charcode c) = 8 - and isalpha c = Array.get ctable (charcode c) = 16 - and isnum c = Array.get ctable (charcode c) = 32 - and isalnum c = Array.get ctable (charcode c) >= 16 in - isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; - -let (||) parser1 parser2 input = - try parser1 input - with Noparse -> parser2 input;; - -let (++) parser1 parser2 input = - let result1,rest1 = parser1 input in - let result2,rest2 = parser2 rest1 in - (result1,result2),rest2;; - -let rec many prs input = - try let result,next = prs input in - let results,rest = many prs next in - (result::results),rest - with Noparse -> [],input;; - -let (>>) prs treatment input = - let result,rest = prs input in - treatment(result),rest;; - -let fix err prs input = - try prs input - with Noparse -> failwith (err ^ " expected");; - -let rec listof prs sep err = - prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);; - -let possibly prs input = - try let x,rest = prs input in [x],rest - with Noparse -> [],input;; - -let some p = - function - [] -> raise Noparse - | (h::t) -> if p h then (h,t) else raise Noparse;; - -let a tok = some (fun item -> item = tok);; - -let rec atleast n prs i = - (if n <= 0 then many prs - else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; - -let finished input = - if input = [] then 0,input else failwith "Unparsed input";; - -let word s = - end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t)) - (map a (explode s));; - -let token s = - many (some isspace) ++ word s ++ many (some isspace) - >> (fun ((_,t),_) -> t);; - -let decimal = - let numeral = some isnum in - let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in - let decimalfrac = atleast 1 numeral - >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in - let decimalsig = - decimalint ++ possibly (a "." ++ decimalfrac >> snd) - >> (function (h,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") in - let signed prs = - a "-" ++ prs >> ((o) minus_num snd) - || a "+" ++ prs >> snd - || prs in - let exponent = (a "e" || a "E") ++ signed decimalint >> snd in - signed decimalsig ++ possibly exponent - >> (function (h,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ -> - failwith "exponent");; - -let mkparser p s = - let x,rst = p(explode s) in - if rst = [] then x else failwith "mkparser: unparsed input";; - -let parse_decimal = mkparser decimal;; - -(* ------------------------------------------------------------------------- *) -(* Parse back a vector. *) -(* ------------------------------------------------------------------------- *) - -let parse_csdpoutput = - let rec skipupto dscr prs inp = - (dscr ++ prs >> snd - || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in - let ignore inp = (),[] in - let csdpoutput = - (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++ - (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in - mkparser csdpoutput;; - -(* ------------------------------------------------------------------------- *) -(* CSDP parameters; so far I'm sticking with the defaults. *) -(* ------------------------------------------------------------------------- *) - -let csdp_default_parameters = -"axtol=1.0e-8 -atytol=1.0e-8 -objtol=1.0e-8 -pinftol=1.0e8 -dinftol=1.0e8 -maxiter=100 -minstepfrac=0.9 -maxstepfrac=0.97 -minstepp=1.0e-8 -minstepd=1.0e-8 -usexzgap=1 -tweakgap=0 -affine=0 -printlevel=1 -";; - -let csdp_params = csdp_default_parameters;; - -(* ------------------------------------------------------------------------- *) -(* The same thing with CSDP. *) -(* Modified by the Coq development team to use a cache *) -(* ------------------------------------------------------------------------- *) - -let buffer_add_line buff line = - Buffer.add_string buff line; Buffer.add_char buff '\n' - -let string_of_file filename = - let fd = open_in filename in - let buff = Buffer.create 16 in - try while true do buffer_add_line buff (input_line fd) done; failwith "" - with End_of_file -> (close_in fd; Buffer.contents buff) - -let file_of_string filename s = - let fd = Pervasives.open_out filename in - output_string fd s; close_out fd - -let request_mark = "*** REQUEST ***" -let answer_mark = "*** ANSWER ***" -let end_mark = "*** END ***" -let infeasible_mark = "Infeasible\n" -let failure_mark = "Failure\n" - -let cache_name = "csdp.cache" - -let look_in_cache string_problem = - let n = String.length string_problem in - try - let inch = open_in cache_name in - let rec search () = - while input_line inch <> request_mark do () done; - let i = ref 0 in - while !i < n & string_problem.[!i] = input_char inch do incr i done; - if !i < n or input_line inch <> answer_mark then - search () - else begin - let buff = Buffer.create 16 in - let line = ref (input_line inch) in - while (!line <> end_mark) do - buffer_add_line buff !line; line := input_line inch - done; - close_in inch; - Buffer.contents buff - end in - try search () with End_of_file -> close_in inch; raise Not_found - with Sys_error _ -> raise Not_found - -let flush_to_cache string_problem string_result = - try - let flags = [Open_append;Open_text;Open_creat] in - let outch = open_out_gen flags 0o666 cache_name in - begin - try - Printf.fprintf outch "%s\n" request_mark; - Printf.fprintf outch "%s" string_problem; - Printf.fprintf outch "%s\n" answer_mark; - Printf.fprintf outch "%s" string_result; - Printf.fprintf outch "%s\n" end_mark; - with Sys_error _ as e -> close_out outch; raise e - end; - close_out outch - with Sys_error _ -> - print_endline "Warning: Could not open or write to csdp cache" - -exception CsdpInfeasible - -let run_csdp dbg string_problem = - try - let res = look_in_cache string_problem in - if res = infeasible_mark then raise CsdpInfeasible; - if res = failure_mark then failwith "csdp error"; - res - with Not_found -> - let input_file = Filename.temp_file "sos" ".dat-s" in - let output_file = Filename.temp_file "sos" ".dat-s" in - let temp_path = Filename.dirname input_file in - let params_file = Filename.concat temp_path "param.csdp" in - file_of_string input_file string_problem; - file_of_string params_file csdp_params; - let rv = Sys.command("cd "^temp_path^"; csdp "^input_file^" "^output_file^ - (if dbg then "" else "> /dev/null")) in - if rv = 1 or rv = 2 then - (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible); - if rv = 127 then - (print_string "csdp not found, exiting..."; exit 1); - if rv <> 0 & rv <> 3 (* reduced accuracy *) then - (flush_to_cache string_problem failure_mark; - failwith("csdp: error "^string_of_int rv)); - let string_result = string_of_file output_file in - flush_to_cache string_problem string_result; - if not dbg then - (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file); - string_result - -let csdp obj mats = - try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats)) - with CsdpInfeasible -> failwith "csdp: Problem is infeasible" - -(* ------------------------------------------------------------------------- *) -(* Try some apparently sensible scaling first. Note that this is purely to *) -(* get a cleaner translation to floating-point, and doesn't affect any of *) -(* the results, in principle. In practice it seems a lot better when there *) -(* are extreme numbers in the original problem. *) -(* ------------------------------------------------------------------------- *) - -let scale_then = - let common_denominator amat acc = - foldl (fun a m c -> lcm_num (denominator c) a) acc amat - and maximal_element amat acc = - foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in - fun solver obj mats -> - let cd1 = itlist common_denominator mats (Int 1) - and cd2 = common_denominator (snd obj) (Int 1) in - let mats' = map (mapf (fun x -> cd1 */ x)) mats - and obj' = vector_cmul cd2 obj in - let max1 = itlist maximal_element mats' (Int 0) - and max2 = maximal_element (snd obj') (Int 0) in - let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) - and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in - let mats'' = map (mapf (fun x -> x */ scal1)) mats' - and obj'' = vector_cmul scal2 obj' in - solver obj'' mats'';; - -(* ------------------------------------------------------------------------- *) -(* Round a vector to "nice" rationals. *) -(* ------------------------------------------------------------------------- *) - -let nice_rational n x = round_num (n */ x) // n;; - -let nice_vector n = mapa (nice_rational n);; - -(* ------------------------------------------------------------------------- *) -(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *) -(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *) -(* ------------------------------------------------------------------------- *) - -let linear_program_basic a = - let m,n = dimensions a in - let mats = map (fun j -> diagonal (column j a)) (1--n) - and obj = vector_const (Int 1) m in - try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true - with CsdpInfeasible -> false - -(* ------------------------------------------------------------------------- *) -(* Test whether a point is in the convex hull of others. Rather than use *) -(* computational geometry, express as linear inequalities and call CSDP. *) -(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *) -(* ------------------------------------------------------------------------- *) - -let in_convex_hull pts pt = - let pts1 = (1::pt) :: map (fun x -> 1::x) pts in - let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in - let n = length pts + 1 - and v = 2 * (length pt + 1) in - let m = v + n - 1 in - let mat = - (m,n), - itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x)) - (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in - linear_program_basic mat;; - -(* ------------------------------------------------------------------------- *) -(* Filter down a set of points to a minimal set with the same convex hull. *) -(* ------------------------------------------------------------------------- *) - -let minimal_convex_hull = - let augment1 = function (m::ms) -> if in_convex_hull ms m then ms else ms@[m] - | _ -> failwith "augment1" - in - let augment m ms = funpow 3 augment1 (m::ms) in - fun mons -> - let mons' = itlist augment (tl mons) [hd mons] in - funpow (length mons') augment1 mons';; - -(* ------------------------------------------------------------------------- *) -(* Stuff for "equations" (generic A->num functions). *) -(* ------------------------------------------------------------------------- *) - -let equation_cmul c eq = - if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;; - -let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;; - -let equation_eval assig eq = - let value v = apply assig v in - foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;; - -(* ------------------------------------------------------------------------- *) -(* Eliminate among linear equations: return unconstrained variables and *) -(* assignments for the others in terms of them. We give one pseudo-variable *) -(* "one" that's used for a constant term. *) -(* ------------------------------------------------------------------------- *) - - -let eliminate_equations = - let rec extract_first p l = - match l with - [] -> failwith "extract_first" - | h::t -> if p(h) then h,t else - let k,s = extract_first p t in - k,h::s in - let rec eliminate vars dun eqs = - match vars with - [] -> if forall is_undefined eqs then dun - else (raise Unsolvable) - | v::vs -> - try let eq,oeqs = extract_first (fun e -> defined e v) eqs in - let a = apply eq v in - let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in - let elim e = - let b = tryapplyd e v (Int 0) in - if b =/ Int 0 then e else - equation_add e (equation_cmul (minus_num b // a) eq) in - eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs) - with Failure _ -> eliminate vs dun eqs in - fun one vars eqs -> - let assig = eliminate vars undefined eqs in - let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in - setify vs,assig;; - -(* ------------------------------------------------------------------------- *) -(* Eliminate all variables, in an essentially arbitrary order. *) -(* ------------------------------------------------------------------------- *) - -let eliminate_all_equations one = - let choose_variable eq = - let (v,_) = choose eq in - if v = one then - let eq' = undefine v eq in - if is_undefined eq' then failwith "choose_variable" else - let (w,_) = choose eq' in w - else v in - let rec eliminate dun eqs = - match eqs with - [] -> dun - | eq::oeqs -> - if is_undefined eq then eliminate dun oeqs else - let v = choose_variable eq in - let a = apply eq v in - let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in - let elim e = - let b = tryapplyd e v (Int 0) in - if b =/ Int 0 then e else - equation_add e (equation_cmul (minus_num b // a) eq) in - eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in - fun eqs -> - let assig = eliminate undefined eqs in - let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in - setify vs,assig;; - -(* ------------------------------------------------------------------------- *) -(* Solve equations by assigning arbitrary numbers. *) -(* ------------------------------------------------------------------------- *) - -let solve_equations one eqs = - let vars,assigs = eliminate_all_equations one eqs in - let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in - let ass = - combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in - if forall (fun e -> equation_eval ass e =/ Int 0) eqs - then undefine one ass else raise Sanity;; - -(* ------------------------------------------------------------------------- *) -(* Hence produce the "relevant" monomials: those whose squares lie in the *) -(* Newton polytope of the monomials in the input. (This is enough according *) -(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *) -(* vol 45, pp. 363--374, 1978. *) -(* *) -(* These are ordered in sort of decreasing degree. In particular the *) -(* constant monomial is last; this gives an order in diagonalization of the *) -(* quadratic form that will tend to display constants. *) -(* ------------------------------------------------------------------------- *) - -let newton_polytope pol = - let vars = poly_variables pol in - let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol) - and ds = map (fun x -> (degree x pol + 1) / 2) vars in - let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] - and mons' = minimal_convex_hull mons in - let all' = - filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in - map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) - vars m monomial_1) (rev all');; - -(* ------------------------------------------------------------------------- *) -(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *) -(* ------------------------------------------------------------------------- *) - -let diag m = - let nn = dimensions m in - let n = fst nn in - if snd nn <> n then failwith "diagonalize: non-square matrix" else - let rec diagonalize i m = - if is_zero m then [] else - let a11 = element m (i,i) in - if a11 </ Int 0 then failwith "diagonalize: not PSD" - else if a11 =/ Int 0 then - if is_zero(row i m) then diagonalize (i + 1) m - else failwith "diagonalize: not PSD" - else - let v = row i m in - let v' = mapa (fun a1k -> a1k // a11) v in - let m' = - (n,n), - iter (i+1,n) (fun j -> - iter (i+1,n) (fun k -> - ((j,k) |--> (element m (j,k) -/ element v j */ element v' k)))) - undefined in - (a11,v')::diagonalize (i + 1) m' in - diagonalize 1 m;; - -(* ------------------------------------------------------------------------- *) -(* Adjust a diagonalization to collect rationals at the start. *) -(* ------------------------------------------------------------------------- *) - -let deration d = - if d = [] then Int 0,d else - let adj(c,l) = - let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) // - foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in - (c // (a */ a)),mapa (fun x -> a */ x) l in - let d' = map adj d in - let a = itlist ((o) lcm_num ((o) denominator fst)) d' (Int 1) // - itlist ((o) gcd_num ((o) numerator fst)) d' (Int 0) in - (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';; - -(* ------------------------------------------------------------------------- *) -(* Enumeration of monomials with given multidegree bound. *) -(* ------------------------------------------------------------------------- *) - -let rec enumerate_monomials d vars = - if d < 0 then [] - else if d = 0 then [undefined] - else if vars = [] then [monomial_1] else - let alts = - map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in - map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths) - (0--d) in - end_itlist (@) alts;; - -(* ------------------------------------------------------------------------- *) -(* Enumerate products of distinct input polys with degree <= d. *) -(* We ignore any constant input polynomials. *) -(* Give the output polynomial and a record of how it was derived. *) -(* ------------------------------------------------------------------------- *) - -let rec enumerate_products d pols = - if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else - match pols with - [] -> [poly_const num_1,Rational_lt num_1] - | (p,b)::ps -> let e = multidegree p in - if e = 0 then enumerate_products d ps else - enumerate_products d ps @ - map (fun (q,c) -> poly_mul p q,Product(b,c)) - (enumerate_products (d - e) ps);; - -(* ------------------------------------------------------------------------- *) -(* Multiply equation-parametrized poly by regular poly and add accumulator. *) -(* ------------------------------------------------------------------------- *) - -let epoly_pmul p q acc = - foldl (fun a m1 c -> - foldl (fun b m2 e -> - let m = monomial_mul m1 m2 in - let es = tryapplyd b m undefined in - (m |-> equation_add (equation_cmul c e) es) b) - a q) acc p;; - -(* ------------------------------------------------------------------------- *) -(* Usual operations on equation-parametrized poly. *) -(* ------------------------------------------------------------------------- *) - -let epoly_cmul c l = - if c =/ Int 0 then undefined else mapf (equation_cmul c) l;; - -let epoly_neg x = epoly_cmul (Int(-1)) x;; - -let epoly_add x = combine equation_add is_undefined x;; - -let epoly_sub p q = epoly_add p (epoly_neg q);; - -(* ------------------------------------------------------------------------- *) -(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *) -(* ------------------------------------------------------------------------- *) - -let epoly_of_poly p = - foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;; - -(* ------------------------------------------------------------------------- *) -(* String for block diagonal matrix numbered k. *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_blockdiagonal k m = - let pfx = string_of_int k ^" " in - let ents = - foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in - let entss = sort (increasing fst) ents in - itlist (fun ((b,i,j),c) a -> - pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ - " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; - -(* ------------------------------------------------------------------------- *) -(* SDPA for problem using block diagonal (i.e. multiple SDPs) *) -(* ------------------------------------------------------------------------- *) - -let sdpa_of_blockproblem comment nblocks blocksizes obj mats = - let m = length mats - 1 in - "\"" ^ comment ^ "\"\n" ^ - string_of_int m ^ "\n" ^ - string_of_int nblocks ^ "\n" ^ - (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^ - "\n" ^ - sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) - (1--length mats) mats "";; - -(* ------------------------------------------------------------------------- *) -(* Hence run CSDP on a problem in block diagonal form. *) -(* ------------------------------------------------------------------------- *) - -let csdp_blocks nblocks blocksizes obj mats = - let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in - try parse_csdpoutput (run_csdp !debugging string_problem) - with CsdpInfeasible -> failwith "csdp: Problem is infeasible" - -(* ------------------------------------------------------------------------- *) -(* 3D versions of matrix operations to consider blocks separately. *) -(* ------------------------------------------------------------------------- *) - -let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);; - -let bmatrix_cmul c bm = - if c =/ Int 0 then undefined - else mapf (fun x -> c */ x) bm;; - -let bmatrix_neg = bmatrix_cmul (Int(-1));; - -let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);; - -(* ------------------------------------------------------------------------- *) -(* Smash a block matrix into components. *) -(* ------------------------------------------------------------------------- *) - -let blocks blocksizes bm = - map (fun (bs,b0) -> - let m = foldl - (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) - undefined bm in - (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m in*) - (((bs,bs),m):matrix)) - (zip blocksizes (1--length blocksizes));; - -(* ------------------------------------------------------------------------- *) -(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) -(* ------------------------------------------------------------------------- *) - -let real_positivnullstellensatz_general linf d eqs leqs pol - : poly list * (positivstellensatz * (num * poly) list) list = - - let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in - let monoid = - if linf then - (poly_const num_1,Rational_lt num_1):: - (filter (fun (p,c) -> multidegree p <= d) leqs) - else enumerate_products d leqs in - let nblocks = length monoid in - let mk_idmultiplier k p = - let e = d - multidegree p in - let mons = enumerate_monomials e vars in - let nons = zip mons (1--length mons) in - mons, - itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in - let mk_sqmultiplier k (p,c) = - let e = (d - multidegree p) / 2 in - let mons = enumerate_monomials e vars in - let nons = zip mons (1--length mons) in - mons, - itlist (fun (m1,n1) -> - itlist (fun (m2,n2) a -> - let m = monomial_mul m1 m2 in - if n1 > n2 then a else - let c = if n1 = n2 then Int 1 else Int 2 in - let e = tryapplyd a m undefined in - (m |-> equation_add ((k,n1,n2) |=> c) e) a) - nons) - nons undefined in - let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid) - and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in - let blocksizes = map length sqmonlist in - let bigsum = - itlist2 (fun p q a -> epoly_pmul p q a) eqs ids - (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs - (epoly_of_poly(poly_neg pol))) in - let eqns = foldl (fun a m e -> e::a) [] bigsum in - let pvs,assig = eliminate_all_equations (0,0,0) eqns in - let qvars = (0,0,0)::pvs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in - let mk_matrix v = - foldl (fun m (b,i,j) ass -> if b < 0 then m else - let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else - ((b,j,i) |-> c) (((b,i,j) |-> c) m)) - undefined allassig in - let diagents = foldl - (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a) - undefined allassig in - let mats = map mk_matrix qvars - and obj = length pvs, - itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) - undefined in - let raw_vec = if pvs = [] then vector_0 0 - else scale_then (csdp_blocks nblocks blocksizes) obj mats in - let find_rounding d = - (if !debugging then - (Format.print_string("Trying rounding with limit "^string_of_num d); - Format.print_newline()) - else ()); - let vec = nice_vector d raw_vec in - let blockmat = iter (1,dim vec) - (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) - (bmatrix_neg (el 0 mats)) in - let allmats = blocks blocksizes blockmat in - vec,map diag allmats in - let vec,ratdias = - if pvs = [] then find_rounding num_1 - else tryfind find_rounding (map Num.num_of_int (1--31) @ - map pow2 (5--66)) in - let newassigs = - itlist (fun k -> el (k - 1) pvs |-> element vec k) - (1--dim vec) ((0,0,0) |=> Int(-1)) in - let finalassigs = - foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs - allassig in - let poly_of_epoly p = - foldl (fun a v e -> (v |--> equation_eval finalassigs e) a) - undefined p in - let mk_sos mons = - let mk_sq (c,m) = - c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) - (1--length mons) undefined in - map mk_sq in - let sqs = map2 mk_sos sqmonlist ratdias - and cfs = map poly_of_epoly ids in - let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in - let eval_sq sqs = itlist - (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in - let sanity = - itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq - (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs - (poly_neg pol)) in - if not(is_undefined sanity) then raise Sanity else - cfs,map (fun (a,b) -> snd a,b) msq;; - - -let term_of_monoid l1 m = itlist (fun i m -> Mul (nth l1 i,m)) m (Const num_1) - -let rec term_of_pos l1 x = match x with - Axiom_eq i -> failwith "term_of_pos" - | Axiom_le i -> nth l1 i - | Axiom_lt i -> nth l1 i - | Monoid m -> term_of_monoid l1 m - | Rational_eq n -> Const n - | Rational_le n -> Const n - | Rational_lt n -> Const n - | Square t -> Pow (t, 2) - | Eqmul (t, y) -> Mul (t, term_of_pos l1 y) - | Sum (y, z) -> Add (term_of_pos l1 y, term_of_pos l1 z) - | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);; - - -let dest_monomial mon = sort (increasing fst) (graph mon);; - -let monomial_order = - let rec lexorder l1 l2 = - match (l1,l2) with - [],[] -> true - | vps,[] -> false - | [],vps -> true - | ((x1,n1)::vs1),((x2,n2)::vs2) -> - if x1 < x2 then true - else if x2 < x1 then false - else if n1 < n2 then false - else if n2 < n1 then true - else lexorder vs1 vs2 in - fun m1 m2 -> - if m2 = monomial_1 then true else if m1 = monomial_1 then false else - let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in - let deg1 = itlist ((o) (+) snd) mon1 0 - and deg2 = itlist ((o) (+) snd) mon2 0 in - if deg1 < deg2 then false else if deg1 > deg2 then true - else lexorder mon1 mon2;; - -let dest_poly p = - map (fun (m,c) -> c,dest_monomial m) - (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));; - -(* ------------------------------------------------------------------------- *) -(* Map back polynomials and their composites to term. *) -(* ------------------------------------------------------------------------- *) - -let term_of_varpow = - fun x k -> - if k = 1 then Var x else Pow (Var x, k);; - -let term_of_monomial = - fun m -> if m = monomial_1 then Const num_1 else - let m' = dest_monomial m in - let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in - end_itlist (fun s t -> Mul (s,t)) vps;; - -let term_of_cmonomial = - fun (m,c) -> - if m = monomial_1 then Const c - else if c =/ num_1 then term_of_monomial m - else Mul (Const c,term_of_monomial m);; - -let term_of_poly = - fun p -> - if p = poly_0 then Zero else - let cms = map term_of_cmonomial - (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in - end_itlist (fun t1 t2 -> Add (t1,t2)) cms;; - -let term_of_sqterm (c,p) = - Product(Rational_lt c,Square(term_of_poly p));; - -let term_of_sos (pr,sqs) = - if sqs = [] then pr - else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));; - -let rec deepen f n = - try (*print_string "Searching with depth limit "; - print_int n; print_newline();*) f n - with Failure _ -> deepen f (n + 1);; - - - - - -exception TooDeep - -let deepen_until limit f n = - match compare limit 0 with - | 0 -> raise TooDeep - | -1 -> deepen f n - | _ -> - let rec d_until f n = - try if !debugging - then (print_string "Searching with depth limit "; - print_int n; print_newline()) ; f n - with Failure x -> - if !debugging then (Printf.printf "solver error : %s\n" x) ; - if n = limit then raise TooDeep else d_until f (n + 1) in - d_until f n - - -(* patch to remove zero polynomials from equalities. - In this case, hol light loops *) - -let real_nonlinear_prover depthmax eqs les lts = - let eq = map poly_of_term eqs - and le = map poly_of_term les - and lt = map poly_of_term lts in - let pol = itlist poly_mul lt (poly_const num_1) - and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1))) - and ltp = map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1))) - and eqp = itlist2 (fun t i res -> - if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) [] - in - - let proof = - let leq = lep @ ltp in - let eq = List.map fst eqp in - let tryall d = - let e = multidegree pol (*and pol' = poly_neg pol*) in - let k = if e = 0 then 1 else d / e in - tryfind (fun i -> d,i, - real_positivnullstellensatz_general false d eq leq - (poly_neg(poly_pow pol i))) - (0--k) in - let d,i,(cert_ideal,cert_cone) = deepen_until depthmax tryall 0 in - let proofs_ideal = - map2 (fun q i -> Eqmul(term_of_poly q,i)) - cert_ideal (List.map snd eqp) - and proofs_cone = map term_of_sos cert_cone - and proof_ne = - if lt = [] then Rational_lt num_1 else - let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in - funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in - end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in - if !debugging then (print_string("Translating proof certificate to Coq"); print_newline()); - proof;; - - -(* ------------------------------------------------------------------------- *) -(* Now pure SOS stuff. *) -(* ------------------------------------------------------------------------- *) - -(* ------------------------------------------------------------------------- *) -(* Some combinatorial helper functions. *) -(* ------------------------------------------------------------------------- *) - -let rec allpermutations l = - if l = [] then [[]] else - itlist (fun h acc -> map (fun t -> h::t) - (allpermutations (subtract l [h])) @ acc) l [];; - -let allvarorders l = - map (fun vlis x -> index x vlis) (allpermutations l);; - -let changevariables_monomial zoln (m:monomial) = - foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;; - -let changevariables zoln pol = - foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a) - poly_0 pol;; - -(* ------------------------------------------------------------------------- *) -(* Sum-of-squares function with some lowbrow symmetry reductions. *) -(* ------------------------------------------------------------------------- *) - -let sumofsquares_general_symmetry tool pol = - let vars = poly_variables pol - and lpps = newton_polytope pol in - let n = length lpps in - let sym_eqs = - let invariants = filter - (fun vars' -> - is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) - (allpermutations vars) in -(* let lpps2 = allpairs monomial_mul lpps lpps in*) -(* let lpp2_classes = - setify(map (fun m -> - setify(map (fun vars' -> changevariables_monomial (zip vars vars') m) - invariants)) lpps2) in *) - let lpns = zip lpps (1--length lpps) in - let lppcs = - filter (fun (m,(n1,n2)) -> n1 <= n2) - (allpairs - (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in - let clppcs = end_itlist (@) - (map (fun ((m1,m2),(n1,n2)) -> - map (fun vars' -> - (changevariables_monomial (zip vars vars') m1, - changevariables_monomial (zip vars vars') m2),(n1,n2)) - invariants) - lppcs) in - let clppcs_dom = setify(map fst clppcs) in - let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs) - clppcs_dom in - let eqvcls = map (o setify (map snd)) clppcs_cls in - let mk_eq cls acc = - match cls with - [] -> raise Sanity - | [h] -> acc - | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in - itlist mk_eq eqvcls [] in - let eqs = foldl (fun a x y -> y::a) [] - (itern 1 lpps (fun m1 n1 -> - itern 1 lpps (fun m2 n2 f -> - let m = monomial_mul m1 m2 in - if n1 > n2 then f else - let c = if n1 = n2 then Int 1 else Int 2 in - (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f)) - (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a) - undefined pol)) @ - sym_eqs in - let pvs,assig = eliminate_all_equations (0,0) eqs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in - let qvars = (0,0)::pvs in - let diagents = - end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in - let mk_matrix v = - ((n,n), - foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else - ((j,i) |-> c) (((i,j) |-> c) m)) - undefined allassig :matrix) in - let mats = map mk_matrix qvars - and obj = length pvs, - itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0))) - undefined in - let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in - let find_rounding d = - (if !debugging then - (Format.print_string("Trying rounding with limit "^string_of_num d); - Format.print_newline()) - else ()); - let vec = nice_vector d raw_vec in - let mat = iter (1,dim vec) - (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) - (matrix_neg (el 0 mats)) in - deration(diag mat) in - let rat,dia = - if pvs = [] then - let mat = matrix_neg (el 0 mats) in - deration(diag mat) - else - tryfind find_rounding (map Num.num_of_int (1--31) @ - map pow2 (5--66)) in - let poly_of_lin(d,v) = - d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in - let lins = map poly_of_lin dia in - let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in - let sos = poly_cmul rat (end_itlist poly_add sqs) in - if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;; - -let (sumofsquares: poly -> Num.num * (( Num.num * poly) list)) = -sumofsquares_general_symmetry csdp;; diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli deleted file mode 100644 index 31c9518c..00000000 --- a/contrib/micromega/sos.mli +++ /dev/null @@ -1,66 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - - -type vname = string;; - -type term = -| Zero -| Const of Num.num -| Var of vname -| Inv of term -| Opp of term -| Add of (term * term) -| Sub of (term * term) -| Mul of (term * term) -| Div of (term * term) -| Pow of (term * int) - -type positivstellensatz = - Axiom_eq of int - | Axiom_le of int - | Axiom_lt of int - | Rational_eq of Num.num - | Rational_le of Num.num - | Rational_lt of Num.num - | Square of term - | Monoid of int list - | Eqmul of term * positivstellensatz - | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz - -type poly - -val poly_isconst : poly -> bool - -val poly_neg : poly -> poly - -val poly_mul : poly -> poly -> poly - -val poly_pow : poly -> int -> poly - -val poly_const : Num.num -> poly - -val poly_of_term : term -> poly - -val term_of_poly : poly -> term - -val term_of_sos : positivstellensatz * (Num.num * poly) list -> - positivstellensatz - -val string_of_poly : poly -> string - -exception TooDeep - -val deepen_until : int -> (int -> 'a) -> int -> 'a - -val real_positivnullstellensatz_general : bool -> int -> poly list -> - (poly * positivstellensatz) list -> - poly -> poly list * (positivstellensatz * (Num.num * poly) list) list - -val sumofsquares : poly -> Num.num * ( Num.num * poly) list diff --git a/contrib/micromega/vector.ml b/contrib/micromega/vector.ml deleted file mode 100644 index fee4ebfc..00000000 --- a/contrib/micromega/vector.ml +++ /dev/null @@ -1,674 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -open Num - -module type S = -sig - type t - - val fresh : t -> int - - val null : t - - val is_null : t -> bool - - val get : int -> t -> num - - val update : int -> (num -> num) -> t -> t - (* behaviour is undef if index < 0 -- might loop*) - - val set : int -> num -> t -> t - - (* - For efficiency... - - val get_update : int -> (num -> num) -> t -> num * t - *) - - val mul : num -> t -> t - - val uminus : t -> t - - val add : t -> t -> t - - val dotp : t -> t -> num - - val lin_comb : num -> t -> num -> t -> t - (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *) - - val gcd : t -> Big_int.big_int - - val normalise : t -> num * t - - val hash : t -> int - - val compare : t -> t -> int - - type it - - val iterator : t -> it - val element : it -> (num*it) option - - val string : t -> string - - type status = Pos | Neg - - (* the result list is ordered by fst *) - val status : t -> (int * status) list - - val from_list : num list -> t - val to_list : t -> num list - -end - - -module type SystemS = -sig - - module Vect : S - - module Cstr : - sig - type kind = Eq | Ge - val string_of_kind : kind -> string - type cstr = {coeffs : Vect.t ; op : kind ; cst : num} - val string_of_cstr : cstr -> string - val compare : cstr -> cstr -> int - end - open Cstr - - - module CstrBag : - sig - type t - exception Contradiction - - val empty : t - - val is_empty : t -> bool - - val add : cstr -> t -> t - (* c can be deduced from add c t *) - - val find : (cstr -> bool) -> t -> cstr option - - val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a - - val status : t -> (int * (int list * int list)) list - (* aggregate of vector statuses *) - - val remove : cstr -> t -> t - - (* remove_list the ith element -- it is the ith element visited by 'fold' *) - - val split : (cstr -> int) -> t -> (int -> t) - - type it - val iterator : t -> it - val element : it -> (cstr*it) option - - end - -end - -let zero_num = Int 0 -let unit_num = Int 1 - - - - -module Cstr(V:S) = -struct - type kind = Eq | Ge - let string_of_kind = function Eq -> "Eq" | Ge -> "Ge" - - type cstr = {coeffs : V.t ; op : kind ; cst : num} - - let string_of_cstr {coeffs =a ; op = b ; cst =c} = - Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c) - - type t = cstr - let compare - {coeffs = v1 ; op = op1 ; cst = c1} - {coeffs = v2 ; op = op2 ; cst = c2} = - Mutils.Cmp.compare_lexical [ - (fun () -> V.compare v1 v2); - (fun () -> Pervasives.compare op1 op2); - (fun () -> compare_num c1 c2) - ] - - -end - - - -module VList : S with type t = num list = -struct - type t = num list - - let fresh l = failwith "not implemented" - - let null = [] - - let is_null = List.for_all ((=/) zero_num) - - let normalise l = failwith "Not implemented" - (*match l with (* Buggy : What if the first num is zero! *) - | [] -> (Int 0,[]) - | [n] -> (n,[Int 1]) - | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l) - *) - - - let get i l = try List.nth l i with _ -> zero_num - - (* This is not tail-recursive *) - let rec update i f t = - match t with - | [] -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f []) - | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t) - - let rec set i n t = - match t with - | [] -> if i = 0 then [n] else (zero_num)::(set (i-1) n []) - | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t) - - - - - let rec mul z t = - match z with - | Int 0 -> null - | Int 1 -> t - | _ -> List.map (mult_num z) t - - let uminus t = mul (Int (-1)) t - - let rec add t1 t2 = - match t1,t2 with - | [], _ -> t2 - | _ , [] -> t1 - | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2) - - let dotp t1 t2 = - let rec _dotp t1 t2 acc = - match t1, t2 with - | [] , _ -> acc - | _ , [] -> acc - | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in - _dotp t1 t2 zero_num - - let add_mul n t1 t2 = - match n with - | Int 0 -> t2 - | Int 1 -> add t1 t2 - | _ -> - let rec _add_mul t1 t2 = - match t1,t2 with - | [], _ -> t2 - | _ , [] -> mul n t1 - | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in - _add_mul t1 t2 - - let lin_comb n1 t1 n2 t2 = - match n1,n2 with - | Int 0 , _ -> mul n2 t2 - | Int 1 , _ -> add_mul n2 t2 t1 - | _ , Int 0 -> mul n1 t1 - | _ , Int 1 -> add_mul n1 t1 t2 - | _ -> - let rec _lin_comb t1 t2 = - match t1,t2 with - | [], _ -> mul n2 t2 - | _ , [] -> mul n1 t1 - | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in - _lin_comb t1 t2 - - (* could be computed on the fly *) - let gcd t =Mutils.gcd_list t - - - - - let hash = Mutils.Cmp.hash_list int_of_num - - let compare = Mutils.Cmp.compare_list compare_num - - type it = t - let iterator (x:t) : it = x - let element it = - match it with - | [] -> None - | e::l -> Some (e,l) - - (* TODO: Buffer! *) - let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l "" - - type status = Pos | Neg - - let status l = - let rec xstatus i l = - match l with - | [] -> [] - | e::l -> - begin - match compare_num e (Int 0) with - | 1 -> (i,Pos):: (xstatus (i+1) l) - | 0 -> xstatus (i+1) l - | -1 -> (i,Neg) :: (xstatus (i+1) l) - | _ -> assert false - end in - xstatus 0 l - - let from_list l = l - let to_list l = l - -end - -module VMap : S = -struct - module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end) - - type t = num Map.t - - let null = Map.empty - - let fresh m = failwith "not implemented" - - let is_null = Map.is_empty - - let normalise m = failwith "Not implemented" - - - - let get i l = try Map.find i l with _ -> zero_num - - let update i f t = - try - let res = f (Map.find i t) in - if res =/ zero_num - then Map.remove i t - else Map.add i res t - with - Not_found -> - let res = f zero_num in - if res =/ zero_num then t else Map.add i res t - - let set i n t = - if n =/ zero_num then Map.remove i t - else Map.add i n t - - - let rec mul z t = - match z with - | Int 0 -> null - | Int 1 -> t - | _ -> Map.map (mult_num z) t - - let uminus t = mul (Int (-1)) t - - - let map2 f m1 m2 = - let res,m2' = - Map.fold (fun k e (res,m2) -> - let v = f e (get k m2) in - if v =/ zero_num - then (res,Map.remove k m2) - else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in - Map.fold (fun k e res -> - let v = f zero_num e in - if v =/ zero_num - then res else Map.add k v res) m2' res - - let add t1 t2 = map2 (+/) t1 t2 - - - let dotp t1 t2 = - Map.fold (fun k e res -> - res +/ (e */ get k t2)) t1 zero_num - - - - let add_mul n t1 t2 = - match n with - | Int 0 -> t2 - | Int 1 -> add t1 t2 - | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2 - - let lin_comb n1 t1 n2 t2 = - match n1,n2 with - | Int 0 , _ -> mul n2 t2 - | Int 1 , _ -> add_mul n2 t2 t1 - | _ , Int 0 -> mul n1 t1 - | _ , Int 1 -> add_mul n1 t1 t2 - | _ -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2 - - - let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0 - - let compare = Map.compare compare_num - - type it = t * int - - let iterator (x:t) : it = (x,0) - - let element (mp,id) = - try - Some (Map.find id mp, (mp, id+1)) - with - Not_found -> None - - (* TODO: Buffer! *) - type status = Pos | Neg - - let status l = Map.fold (fun k e l -> - match compare_num e (Int 0) with - | 1 -> (k,Pos)::l - | 0 -> l - | -1 -> (k,Neg) :: l - | _ -> assert false) l [] - let from_list l = - let rec from_list i l map = - match l with - | [] -> map - | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in - from_list 0 l Map.empty - - let gcd m = - let res = Map.fold (fun _ e x -> Big_int.gcd_big_int x (Mutils.numerator e)) m Big_int.zero_big_int in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - - - let to_list m = - let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 l - - let string l = VList.string (to_list l) - - -end - - -module VSparse : S = -struct - - type t = (int*num) list - - let null = [] - - let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc) 0 l - - let is_null l = l = [] - - let rec is_sorted l = - match l with - | [] -> true - | [e] -> true - | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l) - - - let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l) - - (* let get i t = - assert (check t); - try List.assoc i t with Not_found -> zero_num *) - - let rec get (i:int) t = - match t with - | [] -> zero_num - | (j,n)::t -> - match compare i j with - | 0 -> n - | 1 -> get i t - | _ -> zero_num - - let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = - match t with - | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Pervasives.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" - - let update i f t = - assert (check t); - let res = update i f t in - assert (check t) ; res - - - let rec set i n t = - match t with - | [] -> cons i n [] - | (k,v)::l -> - match Pervasives.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - - - let rec map f l = - match l with - | [] -> [] - | (i,e)::l -> cons i (f e) (map f l) - - let rec mul z t = - match z with - | Int 0 -> null - | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - - let mul z t = - assert (check t) ; - let res = mul z t in - assert (check res) ; - res - - let uminus t = mul (Int (-1)) t - - - let normalise l = - match l with - | [] -> (Int 0,[]) - | (i,n)::_ -> (n, mul ((Int 1) // n) l) - - - let rec map2 f m1 m2 = - match m1, m2 with - | [] , [] -> [] - | l , [] -> map (fun x -> f x zero_num) l - | [] ,l -> map (f zero_num) l - | (i,e)::l1,(i',e')::l2 -> - match Pervasives.compare i i' with - | 0 -> cons i (f e e') (map2 f l1 l2) - | -1 -> cons i (f e zero_num) (map2 f l1 m2) - | 1 -> cons i' (f zero_num e') (map2 f m1 l2) - | _ -> assert false - - (* let add t1 t2 = map2 (+/) t1 t2*) - - let rec add (m1:t) (m2:t) = - match m1, m2 with - | [] , [] -> [] - | l , [] -> l - | [] ,l -> l - | (i,e)::l1,(i',e')::l2 -> - match Pervasives.compare i i' with - | 0 -> cons i ( e +/ e') (add l1 l2) - | -1 -> (i,e) :: (add l1 m2) - | 1 -> (i', e') :: (add m1 l2) - | _ -> assert false - - - - - let add t1 t2 = - assert (check t1 && check t2); - let res = add t1 t2 in - assert (check res); - res - - - let rec dotp (t1:t) (t2:t) = - match t1, t2 with - | [] , _ -> zero_num - | _ , [] -> zero_num - | (i,e)::l1 , (i',e')::l2 -> - match Pervasives.compare i i' with - | 0 -> (e */ e') +/ (dotp l1 l2) - | -1 -> dotp l1 t2 - | 1 -> dotp t1 l2 - | _ -> assert false - - let dotp t1 t2 = - assert (check t1 && check t2) ; dotp t1 t2 - - let add_mul n t1 t2 = - match n with - | Int 0 -> t2 - | Int 1 -> add t1 t2 - | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2 - - let add_mul n (t1:t) (t2:t) = - match n with - | Int 0 -> t2 - | Int 1 -> add t1 t2 - | _ -> - let rec xadd_mul m1 m2 = - match m1, m2 with - | [] , [] -> [] - | _ , [] -> mul n m1 - | [] , _ -> m2 - | (i,e)::l1,(i',e')::l2 -> - match Pervasives.compare i i' with - | 0 -> cons i ( n */ e +/ e') (xadd_mul l1 l2) - | -1 -> (i,n */ e) :: (xadd_mul l1 m2) - | 1 -> (i', e') :: (xadd_mul m1 l2) - | _ -> assert false in - xadd_mul t1 t2 - - - - - let lin_comb n1 t1 n2 t2 = - match n1,n2 with - | Int 0 , _ -> mul n2 t2 - | Int 1 , _ -> add_mul n2 t2 t1 - | _ , Int 0 -> mul n1 t1 - | _ , Int 1 -> add_mul n1 t1 t2 - | _ -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*) - let rec xlin_comb m1 m2 = - match m1, m2 with - | [] , [] -> [] - | _ , [] -> mul n1 m1 - | [] , _ -> mul n2 m2 - | (i,e)::l1,(i',e')::l2 -> - match Pervasives.compare i i' with - | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb l1 l2) - | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2) - | 1 -> (i', n2 */ e') :: (xlin_comb m1 l2) - | _ -> assert false in - xlin_comb t1 t2 - - - - - - let lin_comb n1 t1 n2 t2 = - assert (check t1 && check t2); - let res = lin_comb n1 t1 n2 t2 in - assert (check res); res - - let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y)) - - - let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical - [ - (fun () -> Pervasives.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) - - (* - let compare (x:t) (y:t) = - let rec xcompare acc1 acc2 x y = - match x , y with - | [] , [] -> xcomp acc1 acc2 - | [] , _ -> -1 - | _ , [] -> 1 - | (i,n1)::l1 , (j,n2)::l2 -> - match Pervasives.compare i j with - | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2 - | c -> c - and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in - xcompare [] [] x y - *) - - type it = t - - let iterator (x:t) : it = x - - let element l = failwith "Not_implemented" - - (* TODO: Buffer! *) - type status = Pos | Neg - - let status l = List.map (fun (i,e) -> - match compare_num e (Int 0) with - | 1 -> i,Pos - | -1 -> i,Neg - | _ -> assert false) l - - let from_list (l: num list) = - let rec xfrom_list i l = - match l with - | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - - let res = xfrom_list 0 l in - assert (check res) ; res - - - let gcd m = - let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Mutils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - - let to_list m = - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 m - - let to_list l = - assert (check l); - to_list l - - - let string l = VList.string (to_list l) - -end diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v deleted file mode 100644 index ee823502..00000000 --- a/contrib/omega/Omega.v +++ /dev/null @@ -1,58 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(* $Id: Omega.v 10028 2007-07-18 22:38:06Z letouzey $ *) - -(* We do not require [ZArith] anymore, but only what's necessary for Omega *) -Require Export ZArith_base. -Require Export OmegaLemmas. -Require Export PreOmega. - -Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l - Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l - Zmult_plus_distr_r: zarith. - -Require Export Zhints. - -(* -(* The constant minus is required in coq_omega.ml *) -Require Minus. -*) - -Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. -Hint Extern 10 (_ <= _) => abstract omega: zarith. -Hint Extern 10 (_ < _) => abstract omega: zarith. -Hint Extern 10 (_ >= _) => abstract omega: zarith. -Hint Extern 10 (_ > _) => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. -Hint Extern 10 (~ _ <= _) => abstract omega: zarith. -Hint Extern 10 (~ _ < _) => abstract omega: zarith. -Hint Extern 10 (~ _ >= _) => abstract omega: zarith. -Hint Extern 10 (~ _ > _) => abstract omega: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. -Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ < _)%Z => abstract omega: zarith. -Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ > _)%Z => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. - -Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v deleted file mode 100644 index 5c240553..00000000 --- a/contrib/omega/OmegaLemmas.v +++ /dev/null @@ -1,302 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(*i $Id: OmegaLemmas.v 11739 2009-01-02 19:33:19Z herbelin $ i*) - -Require Import ZArith_base. -Open Local Scope Z_scope. - -(** Factorization lemmas *) - -Theorem Zred_factor0 : forall n:Z, n = n * 1. - intro x; rewrite (Zmult_1_r x); reflexivity. -Qed. - -Theorem Zred_factor1 : forall n:Z, n + n = n * 2. -Proof. - exact Zplus_diag_eq_mult_2. -Qed. - -Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). -Proof. - intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; trivial with arith. -Qed. - -Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). -Proof. - intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; - trivial with arith. -Qed. - -Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). -Proof. - intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. -Qed. - -Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. -Proof. - intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. -Qed. - -Theorem Zred_factor6 : forall n:Z, n = n + 0. -Proof. - intro; rewrite Zplus_0_r; trivial with arith. -Qed. - -(** Other specific variants of theorems dedicated for the Omega tactic *) - -Lemma new_var : forall x : Z, exists y : Z, x = y. -intros x; exists x; trivial with arith. -Qed. - -Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y. -intros x y H; rewrite H; auto with arith. -Qed. - -Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y. -exact Zplus_le_0_compat. -Qed. - -Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0. - -intros x y k H1 H2 H3; apply (Zmult_integral_l k); - [ unfold not in |- *; intros H4; absurd (k > 0); - [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate - | assumption ] - | rewrite <- H2; assumption ]. -Qed. - -Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0. - -unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0); - [ intros H4; cut (0 <= z * y + x); - [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6; - absurd (z * y + x > 0); - [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate - | apply Zle_gt_trans with x; - [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); - apply Zplus_le_compat_r; rewrite Zmult_comm; - generalize H4; unfold Zgt in |- *; case y; - [ simpl in |- *; intros H7; discriminate H7 - | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); - unfold Zle in |- *; rewrite Zcompare_mult_compat; - exact H6 - | simpl in |- *; intros p H7; discriminate H7 ] - | assumption ] ] - | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ] - | apply Zgt_trans with x; [ assumption | assumption ] ]. -Qed. - -Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0. - -intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith. -Qed. - -Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z. - -intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption. -Qed. - -Lemma OMEGA7 : - forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. - -intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; - apply Zmult_gt_0_le_0_compat; assumption. -Qed. - -Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0. - -intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1); - [ intros H4; absurd (0 < x); - [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; - rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; - assumption - | assumption ] - | intros H4; rewrite H4; trivial with arith ]. -Qed. - -Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0. - -intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l; - rewrite Zplus_0_r; assumption. -Qed. - -Lemma OMEGA10 : - forall v c1 c2 l1 l2 k1 k2 : Z, - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith. -Qed. - -Lemma OMEGA11 : - forall v1 c1 l1 l2 k1 : Z, - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - trivial with arith. -Qed. - -Lemma OMEGA12 : - forall v2 c2 l1 l2 k2 : Z, - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite Zplus_permute; trivial with arith. -Qed. - -Lemma OMEGA13 : - forall (v l1 l2 : Z) (x : positive), - v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. - -intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); - rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; - rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x)); - rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; - trivial with arith. -Qed. - -Lemma OMEGA14 : - forall (v l1 l2 : Z) (x : positive), - v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. - -intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1); - rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; - rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r; - rewrite Zplus_0_r; trivial with arith. -Qed. -Lemma OMEGA15 : - forall v c1 c2 l1 l2 k2 : Z, - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith. -Qed. - -Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k. - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - trivial with arith. -Qed. - -Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. - -unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; - apply Zplus_reg_l with (y * z); rewrite Zplus_comm; - rewrite H3; rewrite H2; auto with arith. -Qed. - -Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0. - -unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1; - rewrite H3; auto with arith. -Qed. - -Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. - -unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x); - [ intros H1; elim Zle_lt_or_eq with (1 := H1); - [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg; - rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption - | intros H2; absurd (x = 0); auto with arith ] - | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm; - apply Zle_left; apply Zsucc_le_reg; simpl in |- *; - apply Zlt_le_succ; auto with arith ]. -Qed. - -Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. - -unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3; - simpl in H3; rewrite Zplus_0_r in H3; trivial with arith. -Qed. - -Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) - (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y). - -Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). - -Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) - (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p). - -Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) - (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p). - -Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := - eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2). - -Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop) - (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) := - eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1). -Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2). - -Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop) - (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) := - eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2). -Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop) - (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k). - -Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x). - -Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) - (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) - (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). - -Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) - (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x). - -Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) - (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y). - -Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) - (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y). - -Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := - eq_ind_r P H (Zopp_involutive x). - -Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). - -Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) - (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p). -Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y). - -Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) - (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). - -Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) - (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). - -Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y). - -Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) - (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y). - -Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) - (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). - -Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) - (H : P y) := eq_ind_r P H (Zred_factor5 x y). - -Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) - (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). diff --git a/contrib/omega/PreOmega.v b/contrib/omega/PreOmega.v deleted file mode 100644 index 47e22a97..00000000 --- a/contrib/omega/PreOmega.v +++ /dev/null @@ -1,445 +0,0 @@ -Require Import Arith Max Min ZArith_base NArith Nnat. - -Open Local Scope Z_scope. - - -(** * zify: the Z-ification tactic *) - -(* This tactic searches for nat and N and positive elements in the goal and - translates everything into Z. It is meant as a pre-processor for - (r)omega; for instance a positivity hypothesis is added whenever - - a multiplication is encountered - - an atom is encountered (that is a variable or an unknown construct) - - Recognized relations (can be handled as deeply as allowed by setoid rewrite): - - { eq, le, lt, ge, gt } on { Z, positive, N, nat } - - Recognized operations: - - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < = - - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat - - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat - - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N -*) - - - - -(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *) - -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - let H:= fresh "H" in assert (H:=thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -Ltac zify_unop t thm a := - (* if a is a scalar, we can simply reduce the unop *) - let isz := isZcst a in - match isz with - | true => simpl (t a) in * - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -Ltac zify_op_1 := - match goal with - | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b - | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b - | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b - | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b - | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a - | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a - | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a - | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a - end. - -Ltac zify_op := repeat zify_op_1. - - - - - -(** II) Conversion from nat to Z *) - - -Definition Z_of_nat' := Z_of_nat. - -Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z_of_nat t) in *; - change Z_of_nat with Z_of_nat' in z; - unfold z in *; clear z. - -Ltac zify_nat_rel := - match goal with - (* I: equalities *) - | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H - | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b) - | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H - | |- context [ @eq nat ?a ?b ] => rewrite (inj_eq_iff a b) - (* II: less than *) - | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H - | |- (lt ?a ?b) => apply (inj_lt_rev a b) - | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H - | |- context [ lt ?a ?b ] => rewrite (inj_lt_iff a b) - (* III: less or equal *) - | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H - | |- (le ?a ?b) => apply (inj_le_rev a b) - | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H - | |- context [ le ?a ?b ] => rewrite (inj_le_iff a b) - (* IV: greater than *) - | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H - | |- (gt ?a ?b) => apply (inj_gt_rev a b) - | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H - | |- context [ gt ?a ?b ] => rewrite (inj_gt_iff a b) - (* V: greater or equal *) - | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H - | |- (ge ?a ?b) => apply (inj_ge_rev a b) - | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H - | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) - end. - -Ltac zify_nat_op := - match goal with - (* misc type conversions: positive/N/Z to nat *) - | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H - | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) - | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H - | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a) - | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H - | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a) - - (* plus -> Zplus *) - | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H - | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b) - - (* min -> Zmin *) - | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H - | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b) - - (* max -> Zmax *) - | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H - | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b) - - (* minus -> Zmax (Zminus ... ...) 0 *) - | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H - | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b) - - (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *) - | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H - | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a) - - (* mult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * - | |- context [ Z_of_nat (mult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * - - (* O -> Z0 *) - | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H - | |- context [ Z_of_nat O ] => simpl (Z_of_nat O) - - (* S -> number or Zsucc *) - | H : context [ Z_of_nat (S ?a) ] |- _ => - let isnat := isnatcst a in - match isnat with - | true => simpl (Z_of_nat (S a)) in H - | _ => rewrite (inj_S a) in H - end - | |- context [ Z_of_nat (S ?a) ] => - let isnat := isnatcst a in - match isnat with - | true => simpl (Z_of_nat (S a)) - | _ => rewrite (inj_S a) - end - - (* atoms of type nat : we add a positivity condition (if not already there) *) - | H : context [ Z_of_nat ?a ] |- _ => - match goal with - | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a - | H' : 0 <= Z_of_nat' a |- _ => fail - | _ => let H:= fresh "H" in - assert (H:=Zle_0_nat a); hide_Z_of_nat a - end - | |- context [ Z_of_nat ?a ] => - match goal with - | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a - | H' : 0 <= Z_of_nat' a |- _ => fail - | _ => let H:= fresh "H" in - assert (H:=Zle_0_nat a); hide_Z_of_nat a - end - end. - -Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - - - - -(* III) conversion from positive to Z *) - -Definition Zpos' := Zpos. -Definition Zneg' := Zneg. - -Ltac hide_Zpos t := - let z := fresh "z" in set (z:=Zpos t) in *; - change Zpos with Zpos' in z; - unfold z in *; clear z. - -Ltac zify_positive_rel := - match goal with - (* I: equalities *) - | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H - | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b) - | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H - | |- context [ @eq positive ?a ?b ] => rewrite (Zpos_eq_iff a b) - (* II: less than *) - | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H - | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) - (* III: less or equal *) - | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H - | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) - (* IV: greater than *) - | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H - | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) - (* V: greater or equal *) - | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H - | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) - end. - -Ltac zify_positive_op := - match goal with - (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) in H - | _ => change (Zneg a) with (- Zpos a) in H - end - | |- context [ Zneg ?a ] => - let isp := isPcst a in - match isp with - | true => change (Zneg a) with (Zneg' a) - | _ => change (Zneg a) with (- Zpos a) - end - - (* misc type conversions: nat to positive *) - | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - - (* Pplus -> Zplus *) - | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H - | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) - - (* Pmin -> Zmin *) - | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H - | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b) - - (* Pmax -> Zmax *) - | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H - | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b) - - (* Pminus -> Zmax 1 (Zminus ... ...) *) - | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H - | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b) - - (* Psucc -> Zsucc *) - | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H - | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a) - - (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *) - | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H - | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a) - - (* Pmult -> Zmult and a positivity hypothesis *) - | H : context [ Zpos (Pmult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * - | |- context [ Zpos (Pmult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * - - (* xO *) - | H : context [ Zpos (xO ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H - | _ => rewrite (Zpos_xO a) in H - end - | |- context [ Zpos (xO ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xO a)) with (Zpos' (xO a)) - | _ => rewrite (Zpos_xO a) - end - (* xI *) - | H : context [ Zpos (xI ?a) ] |- _ => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H - | _ => rewrite (Zpos_xI a) in H - end - | |- context [ Zpos (xI ?a) ] => - let isp := isPcst a in - match isp with - | true => change (Zpos (xI a)) with (Zpos' (xI a)) - | _ => rewrite (Zpos_xI a) - end - - (* xI : nothing to do, just prevent adding a useless positivity condition *) - | H : context [ Zpos xH ] |- _ => hide_Zpos xH - | |- context [ Zpos xH ] => hide_Zpos xH - - (* atoms of type positive : we add a positivity condition (if not already there) *) - | H : context [ Zpos ?a ] |- _ => - match goal with - | H' : Zpos a > 0 |- _ => hide_Zpos a - | H' : Zpos' a > 0 |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a - end - | |- context [ Zpos ?a ] => - match goal with - | H' : Zpos a > 0 |- _ => hide_Zpos a - | H' : Zpos' a > 0 |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a - end - end. - -Ltac zify_positive := - repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. - - - - - -(* IV) conversion from N to Z *) - -Definition Z_of_N' := Z_of_N. - -Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z_of_N t) in *; - change Z_of_N with Z_of_N' in z; - unfold z in *; clear z. - -Ltac zify_N_rel := - match goal with - (* I: equalities *) - | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H - | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b) - | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H - | |- context [ @eq N ?a ?b ] => rewrite (Z_of_N_eq_iff a b) - (* II: less than *) - | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H - | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b) - | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H - | |- context [ (?a<?b)%N ] => rewrite (Z_of_N_lt_iff a b) - (* III: less or equal *) - | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H - | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b) - | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H - | |- context [ (?a<=?b)%N ] => rewrite (Z_of_N_le_iff a b) - (* IV: greater than *) - | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H - | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b) - | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H - | |- context [ (?a>?b)%N ] => rewrite (Z_of_N_gt_iff a b) - (* V: greater or equal *) - | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H - | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b) - | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H - | |- context [ (?a>=?b)%N ] => rewrite (Z_of_N_ge_iff a b) - end. - -Ltac zify_N_op := - match goal with - (* misc type conversions: nat to positive *) - | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H - | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a) - | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H - | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a) - | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H - | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a) - | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H - | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0 - - (* Nplus -> Zplus *) - | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H - | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b) - - (* Nmin -> Zmin *) - | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H - | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b) - - (* Nmax -> Zmax *) - | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H - | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b) - - (* Nminus -> Zmax 0 (Zminus ... ...) *) - | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H - | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b) - - (* Nsucc -> Zsucc *) - | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H - | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a) - - (* Nmult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * - | |- context [ Z_of_N (Nmult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * - - (* atoms of type N : we add a positivity condition (if not already there) *) - | H : context [ Z_of_N ?a ] |- _ => - match goal with - | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a - | H' : 0 <= Z_of_N' a |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a - end - | |- context [ Z_of_N ?a ] => - match goal with - | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a - | H' : 0 <= Z_of_N' a |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a - end - end. - -Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. - - - -(** The complete Z-ification tactic *) - -Ltac zify := - repeat progress (zify_nat; zify_positive; zify_N); zify_op. - diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml deleted file mode 100644 index 58873c2d..00000000 --- a/contrib/omega/coq_omega.ml +++ /dev/null @@ -1,1824 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(* $Id: coq_omega.ml 11735 2009-01-02 17:22:31Z herbelin $ *) - -open Util -open Pp -open Reduction -open Proof_type -open Names -open Nameops -open Term -open Termops -open Declarations -open Environ -open Sign -open Inductive -open Tacticals -open Tacmach -open Evar_refiner -open Tactics -open Clenv -open Logic -open Libnames -open Nametab -open Contradiction - -module OmegaSolver = Omega.MakeOmegaSolver (Bigint) -open OmegaSolver - -(* Added by JCF, 09/03/98 *) - -let elim_id id gl = simplest_elim (pf_global gl id) gl -let resolve_id id gl = apply (pf_global gl id) gl - -let timing timer_name f arg = f arg - -let display_time_flag = ref false -let display_system_flag = ref false -let display_action_flag = ref false -let old_style_flag = ref false - -let read f () = !f -let write f x = f:=x - -open Goptions - -let _ = - declare_bool_option - { optsync = false; - optname = "Omega system time displaying flag"; - optkey = SecondaryTable ("Omega","System"); - optread = read display_system_flag; - optwrite = write display_system_flag } - -let _ = - declare_bool_option - { optsync = false; - optname = "Omega action display flag"; - optkey = SecondaryTable ("Omega","Action"); - optread = read display_action_flag; - optwrite = write display_action_flag } - -let _ = - declare_bool_option - { optsync = false; - optname = "Omega old style flag"; - optkey = SecondaryTable ("Omega","OldStyle"); - optread = read old_style_flag; - optwrite = write old_style_flag } - - -let all_time = timing "Omega " -let solver_time = timing "Solver " -let exact_time = timing "Rewrites " -let elim_time = timing "Elim " -let simpl_time = timing "Simpl " -let generalize_time = timing "Generalize" - -let new_identifier = - let cpt = ref 0 in - (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) - -let new_identifier_state = - let cpt = ref 0 in - (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) - -let new_identifier_var = - let cpt = ref 0 in - (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) - -let new_id = - let cpt = ref 0 in fun () -> incr cpt; !cpt - -let new_var_num = - let cpt = ref 1000 in (fun () -> incr cpt; !cpt) - -let new_var = - let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) - -let display_var i = Printf.sprintf "X%d" i - -let intern_id,unintern_id = - let cpt = ref 0 in - let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : identifier) -> - try Hashtbl.find table name with Not_found -> - let idx = !cpt in - Hashtbl.add table name idx; - Hashtbl.add co_table idx name; - incr cpt; idx), - (fun idx -> - try Hashtbl.find co_table idx with Not_found -> - let v = new_var () in - Hashtbl.add table v idx; Hashtbl.add co_table idx v; v) - -let mk_then = tclTHENLIST - -let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) - -let generalize_tac t = generalize_time (generalize t) -let elim t = elim_time (simplest_elim t) -let exact t = exact_time (Tactics.refine t) -let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s] - -let rev_assoc k = - let rec loop = function - | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l - in - loop - -let tag_hypothesis,tag_of_hyp, hyp_of_tag = - let l = ref ([]:(identifier * int) list) in - (fun h id -> l := (h,id):: !l), - (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"), - (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis") - -let hide_constr,find_constr,clear_tables,dump_tables = - let l = ref ([]:(constr * (identifier * identifier * bool)) list) in - (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"), - (fun () -> l := []), - (fun () -> !l) - -(* Lazy evaluation is used for Coq constants, because this code - is evaluated before the compiled modules are loaded. - To use the constant Zplus, one must type "Lazy.force coq_Zplus" - This is the right way to access to Coq constants in tactics ML code *) - -open Coqlib - -let logic_dir = ["Coq";"Logic";"Decidable"] -let init_arith_modules = init_modules @ arith_modules -let coq_modules = - init_arith_modules @ [logic_dir] @ zarith_base_modules - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let init_arith_constant = gen_constant_in_modules "Omega" init_arith_modules -let constant = gen_constant_in_modules "Omega" coq_modules - -(* Zarith *) -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_Z = lazy (constant "Z") -let coq_comparison = lazy (constant "comparison") -let coq_Gt = lazy (constant "Gt") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") -let coq_Zminus = lazy (constant "Zminus") -let coq_Zsucc = lazy (constant "Zsucc") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Z_of_nat = lazy (constant "Z_of_nat") -let coq_inj_plus = lazy (constant "inj_plus") -let coq_inj_mult = lazy (constant "inj_mult") -let coq_inj_minus1 = lazy (constant "inj_minus1") -let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (constant "inj_S") -let coq_inj_le = lazy (constant "inj_le") -let coq_inj_lt = lazy (constant "inj_lt") -let coq_inj_ge = lazy (constant "inj_ge") -let coq_inj_gt = lazy (constant "inj_gt") -let coq_inj_neq = lazy (constant "inj_neq") -let coq_inj_eq = lazy (constant "inj_eq") -let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") -let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") -let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") -let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") -let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") -let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") -let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") -let coq_OMEGA1 = lazy (constant "OMEGA1") -let coq_OMEGA2 = lazy (constant "OMEGA2") -let coq_OMEGA3 = lazy (constant "OMEGA3") -let coq_OMEGA4 = lazy (constant "OMEGA4") -let coq_OMEGA5 = lazy (constant "OMEGA5") -let coq_OMEGA6 = lazy (constant "OMEGA6") -let coq_OMEGA7 = lazy (constant "OMEGA7") -let coq_OMEGA8 = lazy (constant "OMEGA8") -let coq_OMEGA9 = lazy (constant "OMEGA9") -let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") -let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") -let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") -let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") -let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") -let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") -let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") -let coq_OMEGA17 = lazy (constant "OMEGA17") -let coq_OMEGA18 = lazy (constant "OMEGA18") -let coq_OMEGA19 = lazy (constant "OMEGA19") -let coq_OMEGA20 = lazy (constant "OMEGA20") -let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") -let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") -let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") -let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") -let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") -let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") -let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") -let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") -let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") -let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") -let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") -let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") -let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") -let coq_Zegal_left = lazy (constant "Zegal_left") -let coq_Zne_left = lazy (constant "Zne_left") -let coq_Zlt_left = lazy (constant "Zlt_left") -let coq_Zge_left = lazy (constant "Zge_left") -let coq_Zgt_left = lazy (constant "Zgt_left") -let coq_Zle_left = lazy (constant "Zle_left") -let coq_new_var = lazy (constant "new_var") -let coq_intro_Z = lazy (constant "intro_Z") - -let coq_dec_eq = lazy (constant "dec_eq") -let coq_dec_Zne = lazy (constant "dec_Zne") -let coq_dec_Zle = lazy (constant "dec_Zle") -let coq_dec_Zlt = lazy (constant "dec_Zlt") -let coq_dec_Zgt = lazy (constant "dec_Zgt") -let coq_dec_Zge = lazy (constant "dec_Zge") - -let coq_not_Zeq = lazy (constant "not_Zeq") -let coq_Znot_le_gt = lazy (constant "Znot_le_gt") -let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") -let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") -let coq_Znot_gt_le = lazy (constant "Znot_gt_le") -let coq_neq = lazy (constant "neq") -let coq_Zne = lazy (constant "Zne") -let coq_Zle = lazy (constant "Zle") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zge = lazy (constant "Zge") -let coq_Zlt = lazy (constant "Zlt") - -(* Peano/Datatypes *) -let coq_le = lazy (init_arith_constant "le") -let coq_lt = lazy (init_arith_constant "lt") -let coq_ge = lazy (init_arith_constant "ge") -let coq_gt = lazy (init_arith_constant "gt") -let coq_minus = lazy (init_arith_constant "minus") -let coq_plus = lazy (init_arith_constant "plus") -let coq_mult = lazy (init_arith_constant "mult") -let coq_pred = lazy (init_arith_constant "pred") -let coq_nat = lazy (init_arith_constant "nat") -let coq_S = lazy (init_arith_constant "S") -let coq_O = lazy (init_arith_constant "O") - -(* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = lazy (constant "pred_of_minus") -let coq_le_gt_dec = lazy (constant "le_gt_dec") -let coq_dec_eq_nat = lazy (constant "dec_eq_nat") -let coq_dec_le = lazy (constant "dec_le") -let coq_dec_lt = lazy (constant "dec_lt") -let coq_dec_ge = lazy (constant "dec_ge") -let coq_dec_gt = lazy (constant "dec_gt") -let coq_not_eq = lazy (constant "not_eq") -let coq_not_le = lazy (constant "not_le") -let coq_not_lt = lazy (constant "not_lt") -let coq_not_ge = lazy (constant "not_ge") -let coq_not_gt = lazy (constant "not_gt") - -(* Logic/Decidable *) -let coq_eq_ind_r = lazy (constant "eq_ind_r") - -let coq_dec_or = lazy (constant "dec_or") -let coq_dec_and = lazy (constant "dec_and") -let coq_dec_imp = lazy (constant "dec_imp") -let coq_dec_iff = lazy (constant "dec_iff") -let coq_dec_not = lazy (constant "dec_not") -let coq_dec_False = lazy (constant "dec_False") -let coq_dec_not_not = lazy (constant "dec_not_not") -let coq_dec_True = lazy (constant "dec_True") - -let coq_not_or = lazy (constant "not_or") -let coq_not_and = lazy (constant "not_and") -let coq_not_imp = lazy (constant "not_imp") -let coq_not_iff = lazy (constant "not_iff") -let coq_not_not = lazy (constant "not_not") -let coq_imp_simp = lazy (constant "imp_simp") -let coq_iff = lazy (constant "iff") - -(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) - -(* For unfold *) -open Closure -let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with - | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> - EvalConstRef kn - | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") - -let sp_Zsucc = lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc) -let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus) -let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle) -let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt) -let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge) -let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt) -let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) - -let mk_var v = mkVar (id_of_string v) -let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) -let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) -let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) -let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) -let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) -let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) -let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) -let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) -let mk_not t = mkApp (build_coq_not (), [| t |]) -let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), - [| Lazy.force coq_comparison; t1; t2 |]) -let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) - -let mk_integer n = - let rec loop n = - if n =? one then Lazy.force coq_xH else - mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/two) |]) - in - if n =? zero then Lazy.force coq_Z0 - else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), - [| loop (abs n) |]) - -type omega_constant = - | Zplus | Zmult | Zminus | Zsucc | Zopp - | Plus | Mult | Minus | Pred | S | O - | Zpos | Zneg | Z0 | Z_of_nat - | Eq | Neq - | Zne | Zle | Zlt | Zge | Zgt - | Z | Nat - | And | Or | False | True | Not | Iff - | Le | Lt | Ge | Gt - | Other of string - -type omega_proposition = - | Keq of constr * constr * constr - | Kn - -type result = - | Kvar of identifier - | Kapp of omega_constant * constr list - | Kimp of constr * constr - | Kufo - -let destructurate_prop t = - let c, args = decompose_app t in - match kind_of_term c, args with - | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args) - | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args) - | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args) - | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args) - | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args) - | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args) - | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) - | _, [_;_] when c = build_coq_and () -> Kapp (And,args) - | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) - | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args) - | _, [_] when c = build_coq_not () -> Kapp (Not,args) - | _, [] when c = build_coq_False () -> Kapp (False,args) - | _, [] when c = build_coq_True () -> Kapp (True,args) - | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args) - | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args) - | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args) - | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args) - | Const sp, args -> - Kapp (Other (string_of_id (id_of_global (ConstRef sp))),args) - | Construct csp , args -> - Kapp (Other (string_of_id (id_of_global (ConstructRef csp))), args) - | Ind isp, args -> - Kapp (Other (string_of_id (id_of_global (IndRef isp))),args) - | Var id,[] -> Kvar id - | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" - | _ -> Kufo - -let destructurate_type t = - let c, args = decompose_app t in - match kind_of_term c, args with - | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args) - | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args) - | _ -> Kufo - -let destructurate_term t = - let c, args = decompose_app t in - match kind_of_term c, args with - | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args) - | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args) - | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args) - | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args) - | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args) - | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args) - | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args) - | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args) - | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args) - | _, [_] when c = Lazy.force coq_S -> Kapp (S,args) - | _, [] when c = Lazy.force coq_O -> Kapp (O,args) - | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args) - | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args) - | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args) - | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args) - | Var id,[] -> Kvar id - | _ -> Kufo - -let recognize_number t = - let rec loop t = - match decompose_app t with - | f, [t] when f = Lazy.force coq_xI -> one + two * loop t - | f, [t] when f = Lazy.force coq_xO -> two * loop t - | f, [] when f = Lazy.force coq_xH -> one - | _ -> failwith "not a number" - in - match decompose_app t with - | f, [t] when f = Lazy.force coq_Zpos -> loop t - | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t) - | f, [] when f = Lazy.force coq_Z0 -> zero - | _ -> failwith "not a number" - -type constr_path = - | P_APP of int - (* Abstraction and product *) - | P_BODY - | P_TYPE - (* Case *) - | P_BRANCH of int - | P_ARITY - | P_ARG - -let context operation path (t : constr) = - let rec loop i p0 t = - match (p0,kind_of_term t) with - | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) - | ([], _) -> operation i t - | ((P_APP n :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') - | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> - (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) - let v' = Array.copy v in - v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) - | ((P_ARITY :: p), App (f,l)) -> - appvect (loop i p f,l) - | ((P_ARG :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(0) <- loop i p v'.(0); mkApp (f,v') - | (p, Fix ((_,n as ln),(tys,lna,v))) -> - let l = Array.length v in - let v' = Array.copy v in - v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) - | ((P_BODY :: p), Prod (n,t,c)) -> - (mkProd (n,t,loop (succ i) p c)) - | ((P_BODY :: p), Lambda (n,t,c)) -> - (mkLambda (n,t,loop (succ i) p c)) - | ((P_BODY :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,t,loop (succ i) p c)) - | ((P_TYPE :: p), Prod (n,t,c)) -> - (mkProd (n,loop i p t,c)) - | ((P_TYPE :: p), Lambda (n,t,c)) -> - (mkLambda (n,loop i p t,c)) - | ((P_TYPE :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,loop i p t,c)) - | (p, _) -> - ppnl (Printer.pr_lconstr t); - failwith ("abstract_path " ^ string_of_int(List.length p)) - in - loop 1 path t - -let occurence path (t : constr) = - let rec loop p0 t = match (p0,kind_of_term t) with - | (p, Cast (c,_,_)) -> loop p c - | ([], _) -> t - | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) - | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) - | ((P_ARITY :: p), App (f,_)) -> loop p f - | ((P_ARG :: p), App (f,v)) -> loop p v.(0) - | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) - | ((P_BODY :: p), Prod (n,t,c)) -> loop p c - | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c - | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c - | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term - | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term - | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term - | (p, _) -> - ppnl (Printer.pr_lconstr t); - failwith ("occurence " ^ string_of_int(List.length p)) - in - loop path t - -let abstract_path typ path t = - let term_occur = ref (mkRel 0) in - let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur - -let focused_simpl path gl = - let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - convert_concl_no_check newc DEFAULTcast gl - -let focused_simpl path = simpl_time (focused_simpl path) - -type oformula = - | Oplus of oformula * oformula - | Oinv of oformula - | Otimes of oformula * oformula - | Oatom of identifier - | Oz of bigint - | Oufo of constr - -let rec oprint = function - | Oplus(t1,t2) -> - print_string "("; oprint t1; print_string "+"; - oprint t2; print_string ")" - | Oinv t -> print_string "~"; oprint t - | Otimes (t1,t2) -> - print_string "("; oprint t1; print_string "*"; - oprint t2; print_string ")" - | Oatom s -> print_string (string_of_id s) - | Oz i -> print_string (string_of_bigint i) - | Oufo f -> print_string "?" - -let rec weight = function - | Oatom c -> intern_id c - | Oz _ -> -1 - | Oinv c -> weight c - | Otimes(c,_) -> weight c - | Oplus _ -> failwith "weight" - | Oufo _ -> -1 - -let rec val_of = function - | Oatom c -> mkVar c - | Oz c -> mk_integer c - | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) - | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) - | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) - | Oufo c -> c - -let compile name kind = - let rec loop accu = function - | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r - | Oz n -> - let id = new_id () in - tag_hypothesis name id; - {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly "compile_equation" - in - loop [] - -let rec decompile af = - let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) - | [] -> Oz af.constant - in - loop af.body - -let mkNewMeta () = mkMeta (Evarutil.new_meta()) - -let clever_rewrite_base_poly typ p result theorem gl = - let full = pf_concl gl in - let (abstracted,occ) = abstract_path typ (List.rev p) full in - let t = - applist - (mkLambda - (Name (id_of_string "P"), - mkArrow typ mkProp, - mkLambda - (Name (id_of_string "H"), - applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, - [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), - [abstracted]) - in - exact (applist(t,[mkNewMeta()])) gl - -let clever_rewrite_base p result theorem gl = - clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl - -let clever_rewrite_base_nat p result theorem gl = - clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl - -let clever_rewrite_gen p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base p result theorem - -let clever_rewrite_gen_nat p result (t,args) = - let theorem = applist(t, args) in - clever_rewrite_base_nat p result theorem - -let clever_rewrite p vpath t gl = - let full = pf_concl gl in - let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurence p occ) vpath in - let t' = applist(t, (vargs @ [abstracted])) in - exact (applist(t',[mkNewMeta()])) gl - -let rec shuffle p (t1,t2) = - match t1,t2 with - | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - (clever_rewrite p [[P_APP 1;P_APP 1]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1,t')) - else - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t')) - | Oplus(l1,r1), t2 -> - if weight l1 > weight t2 then - let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, - Oplus(l1, t') - else - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight l2 > weight t1 then - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_permute) - :: tac, - Oplus(l2,t') - else [],Oplus(t1,t2) - | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Bigint.add t1 t2) - | t1,t2 -> - if weight t1 < weight t2 then - [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - else [],Oplus(t1,t2) - -let rec shuffle_mult p_init k1 e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if v1 = v2 then - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA10) - in - if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2]; - [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] - in - loop p_init (e1,e2) - -let rec shuffle_mult_right p_init e1 k2 e2 = - let rec loop p = function - | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if v1 = v2 then - let tac = - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA15) - in - if Bigint.add c1 (Bigint.mult k2 c2) =? zero then - let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) - in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: - loop p (l1,l2) - else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,l2') - else - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> - clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1]; - [P_APP 2; P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA12) :: - loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] - in - loop p_init (e1,e2) - -let rec shuffle_cancel p = function - | [] -> [focused_simpl p] - | ({c=c1}::l1) -> - let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] - (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) - in - tac :: shuffle_cancel p l1 - -let rec scalar p n = function - | Oplus(t1,t2) -> - let tac1,t1' = scalar (P_APP 1 :: p) n t1 and - tac2,t2' = scalar (P_APP 2 :: p) n t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_plus_distr_l) :: - (tac1 @ tac2), Oplus(t1',t2') - | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_opp_comm); - focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_assoc_reverse); - focused_simpl (P_APP 2 :: p)], - Otimes(t1,Oz (n*x)) - | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> [], Otimes(t,Oz n) - | Oz i -> [focused_simpl p],Oz(n*i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) - -let rec scalar_norm p_init = - let rec loop p = function - | [] -> [focused_simpl p_init] - | (_::l) -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l - in - loop p_init - -let rec norm_add p_init = - let rec loop p = function - | [] -> [focused_simpl p_init] - | _:: l -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l - in - loop p_init - -let rec scalar_norm_add p_init = - let rec loop p = function - | [] -> [focused_simpl p_init] - | _ :: l -> - clever_rewrite p - [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; - [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; - [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l - in - loop p_init - -let rec negate p = function - | Oplus(t1,t2) -> - let tac1,t1' = negate (P_APP 1 :: p) t1 and - tac2,t2' = negate (P_APP 2 :: p) t2 in - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_plus_distr) :: - (tac1 @ tac2), - Oplus(t1',t2') - | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t - | Otimes(t1,Oz x) -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_mult_distr_r); - focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) - | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> - let r = Otimes(t,Oz(negone)) in - [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r - | Oz i -> [focused_simpl p],Oz(neg i) - | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) - -let rec transform p t = - let default isnat t' = - try - let v,th,_ = find_constr t' in - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> - let v = new_identifier_var () - and th = new_identifier () in - hide_constr t' v th isnat; - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - in - try match destructurate_term t with - | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in - let tac,t' = shuffle p (t1',t2') in - tac1 @ tac2 @ tac, t' - | Kapp(Zminus,[t1;t2]) -> - let tac,t = - transform p - (mkApp (Lazy.force coq_Zplus, - [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t - | Kapp(Zsucc,[t1]) -> - let tac,t = transform p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t - | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in - begin match t1',t2' with - | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' - | (Oz n,_) -> - let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_comm) in - let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' - | _ -> default false t - end - | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) with _ -> default false t) - | Kvar s -> [],Oatom s - | Kapp(Zopp,[t]) -> - let tac,t' = transform (P_APP 1 :: p) t in - let tac',t'' = negate p t' in - tac @ tac', t'' - | Kapp(Z_of_nat,[t']) -> default true t' - | _ -> default false t - with e when catchable_exception e -> default false t - -let shrink_pair p f1 f2 = - match f1,f2 with - | Oatom v,Oatom _ -> - let r = Otimes(Oatom v,Oz two) in - clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r - | Oatom v, Otimes(_,c2) -> - let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor2), r - | Otimes (v1,c1),Oatom v -> - let r = Otimes(Oatom v,Oplus(c1,Oz one)) in - clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zred_factor3), r - | Otimes (Oatom v,c1),Otimes (v2,c2) -> - let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p - [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor4),r - | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); - flush Pervasives.stdout; error "shrink.1" - end - -let reduce_factor p = function - | Oatom v -> - let r = Otimes(Oatom v,Oz one) in - [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r - | Otimes(Oatom v,Oz n) as f -> [],f - | Otimes(Oatom v,c) -> - let rec compute = function - | Oz n -> n - | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) - | _ -> error "condense.1" - in - [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) - | t -> oprint t; error "reduce_factor.1" - -let rec condense p = function - | Oplus(f1,(Oplus(f2,r) as t)) -> - if weight f1 = weight f2 then begin - let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = - clever_rewrite p - [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zplus_assoc) in - let tac_list,t' = condense p (Oplus(t,r)) in - (assoc_tac :: shrink_tac :: tac_list), t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') - end - | Oplus(f1,Oz n) -> - let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) - | Oplus(f1,f2) -> - if weight f1 = weight f2 then begin - let tac_shrink,t = shrink_pair p f1 f2 in - let tac,t' = condense p t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') - end - | Oz _ as t -> [],t - | t -> - let tac,t' = reduce_factor p t in - let final = Oplus(t',Oz zero) in - let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in - tac @ [tac'], final - -let rec clear_zero p = function - | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> - let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in - let tac',t = clear_zero p r in - tac :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) - | t -> [],t - -let replay_history tactic_normalisation = - let aux = id_of_string "auxiliary" in - let aux1 = id_of_string "auxiliary_1" in - let aux2 = id_of_string "auxiliary_2" in - let izero = mk_integer zero in - let rec loop t = - match t with - | HYP e :: l -> - begin - try - tclTHEN - (List.assoc (hyp_of_tag e.id) tactic_normalisation) - (loop l) - with Not_found -> loop l end - | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let k = if b then negone else one in - let p_initial = [P_APP 1;P_TYPE] in - let tac= shuffle_mult_right p_initial e1.body k e2.body in - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| - val_of eq1; - val_of eq2; - mk_integer k; - mkVar id1; mkVar id2 |])]); - (mk_then tac); - (intros_using [aux]); - (resolve_id aux); - reflexivity - ] - | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac = shuffle_cancel p_initial e1.body in - let solve_le = - let not_sup_sup = mkApp (build_coq_eq (), [| - Lazy.force coq_comparison; - Lazy.force coq_Gt; - Lazy.force coq_Gt |]) - in - tclTHENS - (tclTHENLIST [ - (unfold sp_Zle); - (simpl_in_concl); - intro; - (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] - in - let theorem = - mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; - mkVar (hyp_of_tag e1.id); - mkVar (hyp_of_tag e2.id) |]) - in - tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let rhs = mk_plus (mk_times eq2 kk) dd in - let state_eg = mk_eq eq1 rhs in - let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) - [ tclTHENS - (tclTHENLIST [ - (intros_using [aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intros_using [id]); - (cut (mk_gt kk dd)) ]) - [ tclTHENS - (cut (mk_gt kk izero)) - [ tclTHENLIST [ - (intros_using [aux1; aux2]); - (generalize_tac - [mkApp (Lazy.force coq_Zmult_le_approx, - [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); - (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - (simpl_in_concl); - reflexivity ] ]; - tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] - ]; - tclTHEN (mk_then tac) reflexivity ] - - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let c = floor_div e1.constant k in - let d = Bigint.sub e1.constant (Bigint.mult c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; - body = map_eq_linear (fun c -> c / k) e1.body } in - let eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, - [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - (unfold sp_not); - (intros_using [aux]); - (resolve_id aux); - (mk_then tac); - assumption ] ; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ] - | EXACT_DIVIDE (e1,k) :: l -> - let id = hyp_of_tag e1.id in - let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k in - let state_eq = mk_eq eq1 (mk_times eq2 kk) in - if e1.kind = DISE then - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS - (cut state_eq) - [tclTHENLIST [ - (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, - [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intros_using [id]); - (loop l) ]; - tclTHEN (mk_then tac) reflexivity ] - else - let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) - [ - tclTHENS - (cut (mk_gt kk izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, - [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); - (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] - | (MERGE_EQ(e3,e1,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) - and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] - (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - scalar_norm [P_APP 3] e1.body - in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) - [tclTHENLIST [ - (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, - [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intros_using [id]); - (loop l) ]; - tclTHEN (mk_then tac) reflexivity] - - | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () - and id2 = hyp_of_tag orig.id in - tag_hypothesis id e.id; - let eq1 = val_of(decompile def) - and eq2 = val_of(decompile orig) in - let vid = unintern_id v in - let theorem = - mkApp (build_coq_ex (), [| - Lazy.force coq_Z; - mkLambda - (Name vid, - Lazy.force coq_Z, - mk_eq (mkRel 1) eq1) |]) - in - let mm = mk_integer m in - let p_initial = [P_APP 2;P_TYPE] in - let tac = - clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) - [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - shuffle_mult_right p_initial - orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) - [tclTHENLIST [ - (intros_using [aux]); - (elim_id aux); - (clear [aux]); - (intros_using [vid; aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, - [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - (mk_then tac); - (clear [aux]); - (intros_using [id]); - (loop l) ]; - tclTHEN (exists_tac (inj_open eq1)) reflexivity ] - | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () - and id2 = new_identifier () in - tag_hypothesis id1 e1; tag_hypothesis id2 e2; - let id = hyp_of_tag e.id in - let tac1 = norm_add [P_APP 2;P_TYPE] e.body in - let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in - let eq = val_of(decompile e) in - tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; - tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - if k1 =? one & e2.kind = EQUA then - let tac_thm = - match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 - in - let kk = mk_integer k2 in - let p_initial = - if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in - let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - tclTHENLIST [ - (generalize_tac - [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - (mk_then tac); - (intros_using [id]); - (loop l) - ] - else - let kk1 = mk_integer k1 - and kk2 = mk_integer k2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - (mk_then tac); - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ] - | CONSTANT_NOT_NUL(e,k) :: l -> - tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl - | CONSTANT_NUL(e) :: l -> - tclTHEN (resolve_id (hyp_of_tag e)) reflexivity - | CONSTANT_NEG(e,k) :: l -> - tclTHENLIST [ - (generalize_tac [mkVar (hyp_of_tag e)]); - (unfold sp_Zle); - simpl_in_concl; - (unfold sp_not); - (intros_using [aux]); - (resolve_id aux); - reflexivity - ] - | _ -> tclIDTAC - in - loop - -let normalize p_initial t = - let (tac,t') = transform p_initial t in - let (tac',t'') = condense p_initial t' in - let (tac'',t''') = clear_zero p_initial t'' in - tac @ tac' @ tac'' , t''' - -let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = - let p_initial = [P_APP pos ;P_TYPE] in - let (tac,t') = normalize p_initial t in - let shift_left = - tclTHEN - (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) - (tclTRY (clear [id])) - in - if tac <> [] then - let id' = new_identifier () in - ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) - :: tactic, - compile id' flag t' :: defs) - else - (tactic,defs) - -let destructure_omega gl tac_def (id,c) = - if atompart_of_id id = "State" then - tac_def - else - try match destructurate_prop c with - | Kapp(Eq,[typ;t1;t2]) - when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation - id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def - | Kapp(Zne,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation - id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def - | Kapp(Zle,[t1;t2]) -> - let t = mk_plus t2 (mk_inv t1) in - normalize_equation - id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def - | Kapp(Zlt,[t1;t2]) -> - let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation - id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def - | Kapp(Zge,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation - id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def - | Kapp(Zgt,[t1;t2]) -> - let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation - id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def - | _ -> tac_def - with e when catchable_exception e -> tac_def - -let reintroduce id = - (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using id) - -let coq_omega gl = - clear_tables (); - let tactic_normalisation, system = - List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in - let prelude,sys = - List.fold_left - (fun (tac,sys) (t,(v,th,b)) -> - if b then - let id = new_identifier () in - let i = new_id () in - tag_hypothesis id i; - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_using [v; id]); - (elim_id id); - (clear [id]); - (intros_using [th;id]); - tac ]), - {kind = INEQ; - body = [{v=intern_id v; c=one}]; - constant = zero; id = i} :: sys - else - (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_using [v;th]); - tac ]), - sys) - (tclIDTAC,[]) (dump_tables ()) - in - let system = system @ sys in - if !display_system_flag then display_system display_var system; - if !old_style_flag then begin - try - let _ = simplify (new_id,new_var_num,display_var) false system in - tclIDTAC gl - with UNSOLVABLE -> - let _,path = depend [] [] (history ()) in - if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) gl - end else begin - try - let path = simplify_strong (new_id,new_var_num,display_var) system in - if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) gl - with NO_CONTRADICTION -> error "Omega can't solve this system" - end - -let coq_omega = solver_time coq_omega - -let nat_inject gl = - let rec explore p t = - try match destructurate_term t with - | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_plus),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Mult,[t1;t2]) -> - tclTHENLIST [ - (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_mult),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) - ] - | Kapp(Minus,[t1;t2]) -> - let id = new_identifier () in - tclTHENS - (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) - [ - tclTHENLIST [ - (clever_rewrite_gen p - (mk_minus (mk_inj t1) (mk_inj t2)) - ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); - (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) ]; - (tclTHEN - (clever_rewrite_gen p (mk_integer zero) - ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) - (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) - ] - | Kapp(S,[t']) -> - let rec is_number t = - try match destructurate_term t with - Kapp(S,[t]) -> is_number t - | Kapp(O,[]) -> true - | _ -> false - with e when catchable_exception e -> false - in - let rec loop p t = - try match destructurate_term t with - Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p - (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) - (loop (P_APP 1 :: p) t)) - | _ -> explore p t - with e when catchable_exception e -> explore p t - in - if is_number t' then focused_simpl p else loop p t - | Kapp(Pred,[t]) -> - let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; - mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in - tclTHEN - (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one - ((Lazy.force coq_pred_of_minus),[t])) - (explore p t_minus_one) - | Kapp(O,[]) -> focused_simpl p - | _ -> tclIDTAC - with e when catchable_exception e -> tclIDTAC - - and loop = function - | [] -> tclIDTAC - | (i,t)::lit -> - begin try match destructurate_prop t with - Kapp(Le,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Lt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Ge,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Gt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Neq,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - | Kapp(Eq,[typ;t1;t2]) -> - if pf_conv_x gl typ (Lazy.force coq_nat) then - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 2; P_TYPE] t1); - (explore [P_APP 3; P_TYPE] t2); - (reintroduce i); - (loop lit) - ] - else loop lit - | _ -> loop lit - with e when catchable_exception e -> loop lit end - in - loop (List.rev (pf_hyps_types gl)) gl - -let rec decidability gl t = - match destructurate_prop t with - | Kapp(Or,[t1;t2]) -> - mkApp (Lazy.force coq_dec_or, [| t1; t2; - decidability gl t1; decidability gl t2 |]) - | Kapp(And,[t1;t2]) -> - mkApp (Lazy.force coq_dec_and, [| t1; t2; - decidability gl t1; decidability gl t2 |]) - | Kapp(Iff,[t1;t2]) -> - mkApp (Lazy.force coq_dec_iff, [| t1; t2; - decidability gl t1; decidability gl t2 |]) - | Kimp(t1,t2) -> - mkApp (Lazy.force coq_dec_imp, [| t1; t2; - decidability gl t1; decidability gl t2 |]) - | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; - decidability gl t1 |]) - | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (pf_nf gl typ) with - | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) - | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> errorlabstrm "decidability" - (str "Omega: Can't solve a goal with equality on " ++ - Printer.pr_lconstr typ) - end - | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) - | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |]) - | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |]) - | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |]) - | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |]) - | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |]) - | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |]) - | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |]) - | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) - | Kapp(False,[]) -> Lazy.force coq_dec_False - | Kapp(True,[]) -> Lazy.force coq_dec_True - | Kapp(Other t,_::_) -> error - ("Omega: Unrecognized predicate or connective: "^t) - | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) - | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" - | _ -> error "Omega: Unrecognized proposition" - -let onClearedName id tac = - (* We cannot ensure that hyps can be cleared (because of dependencies), *) - (* so renaming may be necessary *) - tclTHEN - (tclTRY (clear [id])) - (fun gl -> - let id = fresh_id [] id gl in - tclTHEN (introduction id) (tac id) gl) - -let destructure_hyps gl = - let rec loop = function - | [] -> (tclTHEN nat_inject coq_omega) - | (i,body,t)::lit -> - begin try match destructurate_prop t with - | Kapp(False,[]) -> elim_id i - | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit - | Kapp(Or,[t1;t2]) -> - (tclTHENS - (elim_id i) - [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); - onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) - | Kapp(And,[t1;t2]) -> - tclTHENLIST [ - (elim_id i); - (tclTRY (clear [i])); - (fun gl -> - let i1 = fresh_id [] (add_suffix i "_left") gl in - let i2 = fresh_id [] (add_suffix i "_right") gl in - tclTHENLIST [ - (introduction i1); - (introduction i2); - (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) - ] - | Kapp(Iff,[t1;t2]) -> - tclTHENLIST [ - (elim_id i); - (tclTRY (clear [i])); - (fun gl -> - let i1 = fresh_id [] (add_suffix i "_left") gl in - let i2 = fresh_id [] (add_suffix i "_right") gl in - tclTHENLIST [ - introduction i1; - generalize_tac - [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; decidability gl t1; mkVar i1|])]; - onClearedName i1 (fun i1 -> - tclTHENLIST [ - introduction i2; - generalize_tac - [mkApp (Lazy.force coq_imp_simp, - [| t2; t1; decidability gl t2; mkVar i2|])]; - onClearedName i2 (fun i2 -> - loop - ((i1,None,mk_or (mk_not t1) t2):: - (i2,None,mk_or (mk_not t2) t1)::lit)) - ])] gl) - ] - | Kimp(t1,t2) -> - if - is_Prop (pf_type_of gl t1) & - is_Prop (pf_type_of gl t2) & - closed0 t2 - then - tclTHENLIST [ - (generalize_tac [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; decidability gl t1; mkVar i|])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) - ] - else - loop lit - | Kapp(Not,[t]) -> - begin match destructurate_prop t with - Kapp(Or,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) - ] - | Kapp(And,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_and, [| t1; t2; - decidability gl t1; mkVar i|])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) - ] - | Kapp(Iff,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_iff, [| t1; t2; - decidability gl t1; decidability gl t2; mkVar i|])]); - (onClearedName i (fun i -> - (loop ((i,None, - mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2))::lit)))) - ] - | Kimp(t1,t2) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, [| t1; t2; - decidability gl t1;mkVar i |])]); - (onClearedName i (fun i -> - (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) - ] - | Kapp(Not,[t]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; - decidability gl t; mkVar i |])]); - (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) - ] - | Kapp(Zle, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zge, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zlt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zgt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Le, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Ge, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Lt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Gt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Eq,[typ;t1;t2]) -> - if !old_style_flag then begin - match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Z,_) -> - tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) - ] - | _ -> loop lit - end else begin - match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> - (tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_neq, [| t1;t2|])))) - (loop lit)) - | Kapp(Z,_) -> - (tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) - (loop lit)) - | _ -> loop lit - end - | _ -> loop lit - end - | _ -> loop lit - with e when catchable_exception e -> loop lit - end - in - loop (pf_hyps gl) gl - -let destructure_goal gl = - let concl = pf_concl gl in - let rec loop t = - match destructurate_prop t with - | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) - destructure_hyps) - | Kimp(a,b) -> (tclTHEN intro (loop b)) - | Kapp(False,[]) -> destructure_hyps - | _ -> - (tclTHEN - (tclTHEN - (Tactics.refine - (mkApp (Lazy.force coq_dec_not_not, [| t; - decidability gl t; mkNewMeta () |]))) - intro) - (destructure_hyps)) - in - (loop concl) gl - -let destructure_goal = all_time (destructure_goal) - -let omega_solver gl = - Coqlib.check_required_library ["Coq";"omega";"Omega"]; - let result = destructure_goal gl in - (* if !display_time_flag then begin text_time (); - flush Pervasives.stdout end; *) - result diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4 deleted file mode 100644 index 02545b30..00000000 --- a/contrib/omega/g_omega.ml4 +++ /dev/null @@ -1,47 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_omega.ml4 10028 2007-07-18 22:38:06Z letouzey $ *) - -open Coq_omega -open Refiner - -let omega_tactic l = - let tacs = List.map - (function - | "nat" -> Tacinterp.interp <:tactic<zify_nat>> - | "positive" -> Tacinterp.interp <:tactic<zify_positive>> - | "N" -> Tacinterp.interp <:tactic<zify_N>> - | "Z" -> Tacinterp.interp <:tactic<zify_op>> - | s -> Util.error ("No Omega knowledge base for type "^s)) - (Util.list_uniquize (List.sort compare l)) - in - tclTHEN - (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - omega_solver - - -TACTIC EXTEND omega -| [ "omega" ] -> [ omega_tactic [] ] -END - -TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> - [ omega_tactic (List.map Names.string_of_id l) ] -| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] -END - diff --git a/contrib/omega/omega.ml b/contrib/omega/omega.ml deleted file mode 100644 index fd774c16..00000000 --- a/contrib/omega/omega.ml +++ /dev/null @@ -1,716 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(* 13/10/2002 : modified to cope with an external numbering of equations *) -(* and hypothesis. Its use for Omega is not more complex and it makes *) -(* things much simpler for the reflexive version where we should limit *) -(* the number of source of numbering. *) -(**************************************************************************) - -open Names - -module type INT = sig - type bigint - val less_than : bigint -> bigint -> bool - val add : bigint -> bigint -> bigint - val sub : bigint -> bigint -> bigint - val mult : bigint -> bigint -> bigint - val euclid : bigint -> bigint -> bigint * bigint - val neg : bigint -> bigint - val zero : bigint - val one : bigint - val to_string : bigint -> string -end - -let debug = ref false - -module MakeOmegaSolver (Int:INT) = struct - -type bigint = Int.bigint -let (<?) = Int.less_than -let (<=?) x y = Int.less_than x y or x = y -let (>?) x y = Int.less_than y x -let (>=?) x y = Int.less_than y x or x = y -let (=?) = (=) -let (+) = Int.add -let (-) = Int.sub -let ( * ) = Int.mult -let (/) x y = fst (Int.euclid x y) -let (mod) x y = snd (Int.euclid x y) -let zero = Int.zero -let one = Int.one -let two = one + one -let negone = Int.neg one -let abs x = if Int.less_than x zero then Int.neg x else x -let string_of_bigint = Int.to_string -let neg = Int.neg - -(* To ensure that polymorphic (<) is not used mistakenly on big integers *) -(* Warning: do not use (=) either on big int *) -let (<) = ((<) : int -> int -> bool) -let (>) = ((>) : int -> int -> bool) -let (<=) = ((<=) : int -> int -> bool) -let (>=) = ((>=) : int -> int -> bool) - -let pp i = print_int i; print_newline (); flush stdout - -let push v l = l := v :: !l - -let rec pgcd x y = if y =? zero then x else pgcd y (x mod y) - -let pgcd_l = function - | [] -> failwith "pgcd_l" - | x :: l -> List.fold_left pgcd x l - -let floor_div a b = - match a >=? zero , b >? zero with - | true,true -> a / b - | false,false -> a / b - | true, false -> (a-one) / b - one - | false,true -> (a+one) / b - one - -type coeff = {c: bigint ; v: int} - -type linear = coeff list - -type eqn_kind = EQUA | INEQ | DISE - -type afine = { - (* a number uniquely identifying the equation *) - id: int ; - (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) - kind: eqn_kind; - (* the variables and their coefficient *) - body: coeff list; - (* a constant *) - constant: bigint } - -type state_action = { - st_new_eq : afine; - st_def : afine; - st_orig : afine; - st_coef : bigint; - st_var : int } - -type action = - | DIVIDE_AND_APPROX of afine * afine * bigint * bigint - | NOT_EXACT_DIVIDE of afine * bigint - | FORGET_C of int - | EXACT_DIVIDE of afine * bigint - | SUM of int * (bigint * afine) * (bigint * afine) - | STATE of state_action - | HYP of afine - | FORGET of int * int - | FORGET_I of int * int - | CONTRADICTION of afine * afine - | NEGATE_CONTRADICT of afine * afine * bool - | MERGE_EQ of int * afine * int - | CONSTANT_NOT_NUL of int * bigint - | CONSTANT_NUL of int - | CONSTANT_NEG of int * bigint - | SPLIT_INEQ of afine * (int * action list) * (int * action list) - | WEAKEN of int * bigint - -exception UNSOLVABLE - -exception NO_CONTRADICTION - -let display_eq print_var (l,e) = - let _ = - List.fold_left - (fun not_first f -> - print_string - (if f.c <? zero then "- " else if not_first then "+ " else ""); - let c = abs f.c in - if c =? one then - Printf.printf "%s " (print_var f.v) - else - Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); - true) - false l - in - if e >? zero then - Printf.printf "+ %s " (string_of_bigint e) - else if e <? zero then - Printf.printf "- %s " (string_of_bigint (abs e)) - -let rec trace_length l = - let action_length accu = function - | SPLIT_INEQ (_,(_,l1),(_,l2)) -> - accu + one + trace_length l1 + trace_length l2 - | _ -> accu + one in - List.fold_left action_length zero l - -let operator_of_eq = function - | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" - -let kind_of = function - | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" - -let display_system print_var l = - List.iter - (fun { kind=b; body=e; constant=c; id=id} -> - Printf.printf "E%d: " id; - display_eq print_var (e,c); - Printf.printf "%s 0\n" (operator_of_eq b)) - l; - print_string "------------------------\n\n" - -let display_inequations print_var l = - List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; - print_string "------------------------\n\n" - -let sbi = string_of_bigint - -let rec display_action print_var = function - | act :: l -> begin match act with - | DIVIDE_AND_APPROX (e1,e2,k,d) -> - Printf.printf - "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by substracting %s.\n" e1.id (sbi k) (sbi d) - | NOT_EXACT_DIVIDE (e,k) -> - Printf.printf - "Constant in equation E%d is not divisible by the pgcd \ - %s of its other coefficients.\n" e.id (sbi k) - | EXACT_DIVIDE (e,k) -> - Printf.printf - "Equation E%d is divided by the pgcd \ - %s of its coefficients.\n" e.id (sbi k) - | WEAKEN (e,k) -> - Printf.printf - "To ensure a solution in the dark shadow \ - the equation E%d is weakened by %s.\n" e (sbi k) - | SUM (e,(c1,e1),(c2,e2)) -> - Printf.printf - "We state %s E%d = %s %s E%d + %s %s E%d.\n" - (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) - (kind_of e2.kind) e2.id - | STATE { st_new_eq = e } -> - Printf.printf "We define a new equation E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0" - | HYP e -> - Printf.printf "We define E%d: " e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0\n" - | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e - | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 - | MERGE_EQ (e,e1,e2) -> - Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e - | CONTRADICTION (e1,e2) -> - Printf.printf - "Equations E%d and E%d imply a contradiction on their \ - constant factors.\n" e1.id e2.id - | NEGATE_CONTRADICT(e1,e2,b) -> - Printf.printf - "Equations E%d and E%d state that their body is at the same time - equal and different\n" e1.id e2.id - | CONSTANT_NOT_NUL (e,k) -> - Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) - | CONSTANT_NEG(e,k) -> - Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) - | CONSTANT_NUL e -> - Printf.printf "Inequation E%d states 0 != 0.\n" e - | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> - Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; - display_action print_var l1; - print_newline (); - display_action print_var l2; - print_newline () - end; display_action print_var l - | [] -> - flush stdout - -let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) - -(*""*) -let add_event, history, clear_history = - let accu = ref [] in - (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), - (fun () -> !accu), - (fun () -> accu := []) - -let nf_linear = Sort.list (fun x y -> x.v > y.v) - -let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) - -let map_eq_linear f = - let rec loop = function - | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l - | [] -> [] - in - loop - -let map_eq_afine f e = - { id = e.id; kind = e.kind; body = map_eq_linear f e.body; - constant = f e.constant } - -let negate_eq = map_eq_afine (fun x -> neg x) - -let rec sum p0 p1 = match (p0,p1) with - | ([], l) -> l | (l, []) -> l - | (((x1::l1) as l1'), ((x2::l2) as l2')) -> - if x1.v = x2.v then - let c = x1.c + x2.c in - if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 - else if x1.v > x2.v then - x1 :: sum l1 l2' - else - x2 :: sum l1' l2 - -let sum_afine new_eq_id eq1 eq2 = - { kind = eq1.kind; id = new_eq_id (); - body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } - -exception FACTOR1 - -let rec chop_factor_1 = function - | x :: l -> - if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') - | [] -> raise FACTOR1 - -exception CHOPVAR - -let rec chop_var v = function - | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l') - | [] -> raise CHOPVAR - -let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = - if e = [] then begin - match eq_flag with - | EQUA -> - if x =? zero then [] else begin - add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE - end - | DISE -> - if x <> zero then [] else begin - add_event (CONSTANT_NUL id); raise UNSOLVABLE - end - | INEQ -> - if x >=? zero then [] else begin - add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE - end - end else - let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in - if eq_flag=EQUA & x mod gcd <> zero then begin - add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE - end else if eq_flag=DISE & x mod gcd <> zero then begin - add_event (FORGET_C eq.id); [] - end else if gcd <> one then begin - let c = floor_div x gcd in - let d = x - c * gcd in - let new_eq = {id=id; kind=eq_flag; constant=c; - body=map_eq_linear (fun c -> c / gcd) e} in - add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd) - else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); - [new_eq] - end else [eq] - -let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 - ({body=e1; constant=c1} as eq1) = - try - let (f,_) = chop_var v e1 in - let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c - else failwith "eliminate_with_in" in - let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in - add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res - with CHOPVAR -> eq1 - -let omega_mod a b = a - b * floor_div (two * a + b) (two * b) -let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = - let e = original.body in - let sigma = new_var_id () in - let smallest,var = - try - List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p)) - (abs (List.hd e).c, (List.hd e).v) (List.tl e) - with Failure "tl" -> display_system print_var [original] ; failwith "TL" in - let m = smallest + one in - let new_eq = - { constant = omega_mod original.constant m; - body = {c= neg m;v=sigma} :: - map_eq_linear (fun a -> omega_mod a m) original.body; - id = new_eq_id (); kind = EQUA } in - let definition = - { constant = neg (floor_div (two * original.constant + m) (two * m)); - body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m))) - original.body; - id = new_eq_id (); kind = EQUA } in - add_event (STATE {st_new_eq = new_eq; st_def = definition; - st_orig = original; st_coef = m; st_var = sigma}); - let new_eq = List.hd (normalize new_eq) in - let eliminated_var, def = chop_var var new_eq.body in - let other_equations = - Util.list_map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in - let inequations = - Util.list_map_append - (fun e -> - normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in - let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in - let mod_original = map_eq_afine (fun c -> c / m) original' in - add_event (EXACT_DIVIDE (original',m)); - List.hd (normalize mod_original),other_equations,inequations - -let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = - if !debug then display_system print_var (e::other); - try - let v,def = chop_factor_1 e.body in - (Util.list_map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, - Util.list_map_append - (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs) - with FACTOR1 -> - eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs) - -let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = - let rec fst_eq_1 = function - (eq::l) -> - if List.exists (fun x -> abs x.c =? one) eq.body then eq,l - else let (eq',l') = fst_eq_1 l in (eq',eq::l') - | [] -> raise Not_found in - match sys_eq with - [] -> if !debug then display_system print_var sys_ineq; sys_ineq - | (e1::rest) -> - let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in - if eq.body = [] then - if eq.constant =? zero then begin - add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) - end else begin - add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE - end - else - banerjee new_ids - (eliminate_one_equation new_ids (eq,other,sys_ineq)) - -type kind = INVERTED | NORMAL - -let redundancy_elimination new_eq_id system = - let normal = function - ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter - (fun e -> - let ({body=ne} as nx) ,kind = normal e in - if ne = [] then - if nx.constant <? zero then begin - add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE - end else add_event (FORGET_C nx.id) - else - try - let (optnormal,optinvert) = Hashtbl.find table ne in - let final = - if kind = NORMAL then begin - match optnormal with - Some v -> - let kept = - if v.constant <? nx.constant - then begin add_event (FORGET (v.id,nx.id));v end - else begin add_event (FORGET (nx.id,v.id));nx end in - (Some(kept),optinvert) - | None -> Some nx,optinvert - end else begin - match optinvert with - Some v -> - let _kept = - if v.constant >? nx.constant - then begin add_event (FORGET_I (v.id,nx.id));v end - else begin add_event (FORGET_I (nx.id,v.id));nx end in - (optnormal,Some(if v.constant >? nx.constant then v else nx)) - | None -> optnormal,Some nx - end in - begin match final with - (Some high, Some low) -> - if high.constant <? low.constant then begin - add_event(CONTRADICTION (high,negate_eq low)); - raise UNSOLVABLE - end - | _ -> () end; - Hashtbl.remove table ne; - Hashtbl.add table ne final - with Not_found -> - Hashtbl.add table ne - (if kind = NORMAL then (Some nx,None) else (None,Some nx))) - system; - let accu_eq = ref [] in - let accu_ineq = ref [] in - Hashtbl.iter - (fun p0 p1 -> match (p0,p1) with - | (e, (Some x, Some y)) when x.constant =? y.constant -> - let id=new_eq_id () in - add_event (MERGE_EQ(id,x,y.id)); - push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq - | (e, (optnorm,optinvert)) -> - begin match optnorm with - Some x -> push x accu_ineq | _ -> () end; - begin match optinvert with - Some x -> push (negate_eq x) accu_ineq | _ -> () end) - table; - !accu_eq,!accu_ineq - -exception SOLVED_SYSTEM - -let select_variable system = - let table = Hashtbl.create 7 in - let push v c= - try let r = Hashtbl.find table v in r := max !r (abs c) - with Not_found -> Hashtbl.add table v (ref (abs c)) in - List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; - let vmin,cmin = ref (-1), ref zero in - let var_cpt = ref 0 in - Hashtbl.iter - (fun v ({contents = c}) -> - incr var_cpt; - if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end) - table; - if !var_cpt < 1 then raise SOLVED_SYSTEM; - !vmin - -let classify v system = - List.fold_left - (fun (not_occ,below,over) eq -> - try let f,eq' = chop_var v eq.body in - if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) - else (not_occ,below,((neg f.c,eq) :: over)) - with CHOPVAR -> (eq::not_occ,below,over)) - ([],[],[]) system - -let product new_eq_id dark_shadow low high = - List.fold_left - (fun accu (a,eq1) -> - List.fold_left - (fun accu (b,eq2) -> - let eq = - sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) - (map_eq_afine (fun c -> c * a) eq2) in - add_event(SUM(eq.id,(b,eq1),(a,eq2))); - match normalize eq with - | [eq] -> - let final_eq = - if dark_shadow then - let delta = (a - one) * (b - one) in - add_event(WEAKEN(eq.id,delta)); - {id = eq.id; kind=INEQ; body = eq.body; - constant = eq.constant - delta} - else eq - in final_eq :: accu - | (e::_) -> failwith "Product dardk" - | [] -> accu) - accu high) - [] low - -let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = - let v = select_variable system in - let (ineq_out, ineq_low,ineq_high) = classify v system in - let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in - if !debug then display_system print_var expanded; expanded - -let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = - if List.exists (fun e -> e.kind = DISE) system then - failwith "disequation in simplify"; - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - let system = Util.list_map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in - let system = (eqs @ simp_eq,simp_ineq) in - let rec loop1a system = - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in - if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids dark_shadow system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> - if !debug then display_system print_var system; system - in - loop2 (loop1a system) - -let rec depend relie_on accu = function - | act :: l -> - begin match act with - | DIVIDE_AND_APPROX (e,_,_,_) -> - if List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | EXACT_DIVIDE (e,_) -> - if List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | WEAKEN (e,_) -> - if List.mem e relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> - if List.mem e relie_on then - depend (e1.id::e2.id::relie_on) (act::accu) l - else - depend relie_on accu l - | STATE {st_new_eq=e;st_orig=o} -> - if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l - else depend relie_on accu l - | HYP e -> - if List.mem e.id relie_on then depend relie_on (act::accu) l - else depend relie_on accu l - | FORGET_C _ -> depend relie_on accu l - | FORGET _ -> depend relie_on accu l - | FORGET_I _ -> depend relie_on accu l - | MERGE_EQ (e,e1,e2) -> - if List.mem e relie_on then - depend (e1.id::e2::relie_on) (act::accu) l - else - depend relie_on accu l - | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | SPLIT_INEQ _ -> failwith "depend" - end - | [] -> relie_on, accu - -(* -let depend relie_on accu trace = - Printf.printf "Longueur de la trace initiale : %d\n" - (trace_length trace + trace_length accu); - let rel',trace' = depend relie_on accu trace in - Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace'); - rel',trace' -*) - -let solve (new_eq_id,new_eq_var,print_var) system = - try let _ = simplify new_eq_id false system in failwith "no contradiction" - with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) - -let negation (eqs,ineqs) = - let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in - let normal = function - | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED - | e -> e,NORMAL in - let table = Hashtbl.create 7 in - List.iter (fun e -> - let {body=ne;constant=c} ,kind = normal e in - Hashtbl.add table (ne,c) (kind,e)) diseq; - List.iter (fun e -> - assert (e.kind = EQUA); - let {body=ne;constant=c},kind = normal e in - try - let (kind',e') = Hashtbl.find table (ne,c) in - add_event (NEGATE_CONTRADICT (e,e',kind=kind')); - raise UNSOLVABLE - with Not_found -> ()) eqs - -exception FULL_SOLUTION of action list * int list - -let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = - clear_history (); - List.iter (fun e -> add_event (HYP e)) system; - (* Initial simplification phase *) - let rec loop1a system = - negation system; - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq - and loop1b sys_ineq = - let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - if simp_eq = [] then dise @ simp_ineq - else loop1a (simp_eq,dise @ simp_ineq) - in - let rec loop2 system = - try - let expanded = fourier_motzkin new_ids false system in - loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system print_var system; system - in - let rec explode_diseq = function - | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () - and id2 = new_eq_id () in - let e1 = - {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; - constant = neg de.constant - one} in - let new_sys = - List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ - List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs - in - explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) - | ([],ineqs,expl_map) -> ineqs,expl_map - in - try - let system = Util.list_map_append normalize system in - let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in - let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in - let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in - let system = (eqs @ simp_eq,simp_ineq @ dise) in - let system' = loop1a system in - let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in - let first_segment = history () in - let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in - let all_solutions = - List.map - (fun (decomp,sys) -> - clear_history (); - try let _ = loop2 sys in raise NO_CONTRADICTION - with UNSOLVABLE -> - let relie_on,path = depend [] [] (history ()) in - let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in - let red = List.map (fun (x,_,_) -> x) dc in - (red,relie_on,decomp,path)) - sys_exploded - in - let max_count sys = - let tbl = Hashtbl.create 7 in - let augment x = - try incr (Hashtbl.find tbl x) - with Not_found -> Hashtbl.add tbl x (ref 1) in - let eq = ref (-1) and c = ref 0 in - List.iter (function - | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) - | (l,_,_,_) -> List.iter augment l) sys; - Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; - !eq - in - let rec solve systems = - try - let id = max_count systems in - let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l - | [] -> failwith "solve" in - let s1,s2 = - List.partition (fun (_,_,decomp,_) -> sign decomp) systems in - let s1' = - List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in - let s2' = - List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in - let (r1,relie1) = solve s1' - and (r2,relie2) = solve s2' in - let (eq,id1,id2) = List.assoc id explode_map in - [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2 - with FULL_SOLUTION (x0,x1) -> (x0,x1) - in - let act,relie_on = solve all_solutions in - snd(depend relie_on act first_segment) - with UNSOLVABLE -> snd (depend [] [] (history ())) - -end diff --git a/contrib/ring/LegacyArithRing.v b/contrib/ring/LegacyArithRing.v deleted file mode 100644 index e062b731..00000000 --- a/contrib/ring/LegacyArithRing.v +++ /dev/null @@ -1,90 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) - -(* Instantiation of the Ring tactic for the naturals of Arith $*) - -Require Import Bool. -Require Export LegacyRing. -Require Export Arith. -Require Import Eqdep_dec. - -Open Local Scope nat_scope. - -Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := - match n, m with - | O, O => true - | S n', S m' => nateq n' m' - | _, _ => false - end. - -Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m. -Proof. - simple induction n; simple induction m; intros; try contradiction. - trivial. - unfold Is_true in H1. - rewrite (H n1 H1). - trivial. -Qed. - -Hint Resolve nateq_prop: arithring. - -Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq. - split; intros; auto with arith arithring. -(* apply (fun n m p:nat => plus_reg_l m p n) with (n := n). - trivial.*) -Defined. - - -Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. - -Goal forall n:nat, S n = 1 + n. -intro; reflexivity. -Save S_to_plus_one. - -(* Replace all occurrences of (S exp) by (plus (S O) exp), except when - exp is already O and only for those occurrences than can be reached by going - down plus and mult operations *) -Ltac rewrite_S_to_plus_term t := - match constr:t with - | 1 => constr:1 - | (S ?X1) => - let t1 := rewrite_S_to_plus_term X1 in - constr:(1 + t1) - | (?X1 + ?X2) => - let t1 := rewrite_S_to_plus_term X1 - with t2 := rewrite_S_to_plus_term X2 in - constr:(t1 + t2) - | (?X1 * ?X2) => - let t1 := rewrite_S_to_plus_term X1 - with t2 := rewrite_S_to_plus_term X2 in - constr:(t1 * t2) - | _ => constr:t - end. - -(* Apply S_to_plus on both sides of an equality *) -Ltac rewrite_S_to_plus := - match goal with - | |- (?X1 = ?X2) => - try - let t1 := - (**) (**) - rewrite_S_to_plus_term X1 - with t2 := rewrite_S_to_plus_term X2 in - change (t1 = t2) in |- * - | |- (?X1 = ?X2) => - try - let t1 := - (**) (**) - rewrite_S_to_plus_term X1 - with t2 := rewrite_S_to_plus_term X2 in - change (t1 = t2) in |- * - end. - -Ltac ring_nat := rewrite_S_to_plus; ring. diff --git a/contrib/ring/LegacyNArithRing.v b/contrib/ring/LegacyNArithRing.v deleted file mode 100644 index c689fc40..00000000 --- a/contrib/ring/LegacyNArithRing.v +++ /dev/null @@ -1,46 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) - -(* Instantiation of the Ring tactic for the binary natural numbers *) - -Require Import Bool. -Require Export LegacyRing. -Require Export ZArith_base. -Require Import NArith. -Require Import Eqdep_dec. - -Unboxed Definition Neq (n m:N) := - match (n ?= m)%N with - | Datatypes.Eq => true - | _ => false - end. - -Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m. - intros n m H; unfold Neq in H. - apply Ncompare_Eq_eq. - destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. -Qed. - -Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. - split. - apply Nplus_comm. - apply Nplus_assoc. - apply Nmult_comm. - apply Nmult_assoc. - apply Nplus_0_l. - apply Nmult_1_l. - apply Nmult_0_l. - apply Nmult_plus_distr_r. -(* apply Nplus_reg_l.*) - apply Neq_prop. -Qed. - -Add Legacy Semi Ring - N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. diff --git a/contrib/ring/LegacyRing.v b/contrib/ring/LegacyRing.v deleted file mode 100644 index 40323b3d..00000000 --- a/contrib/ring/LegacyRing.v +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *) - -Require Export Bool. -Require Export LegacyRing_theory. -Require Export Quote. -Require Export Ring_normalize. -Require Export Ring_abstract. - -(* As an example, we provide an instantation for bool. *) -(* Other instatiations are given in ArithRing and ZArithRing in the - same directory *) - -Definition BoolTheory : - Ring_Theory xorb andb true false (fun b:bool => b) eqb. -split; simpl in |- *. -destruct n; destruct m; reflexivity. -destruct n; destruct m; destruct p; reflexivity. -destruct n; destruct m; reflexivity. -destruct n; destruct m; destruct p; reflexivity. -destruct n; reflexivity. -destruct n; reflexivity. -destruct n; reflexivity. -destruct n; destruct m; destruct p; reflexivity. -destruct x; destruct y; reflexivity || simpl in |- *; tauto. -Defined. - -Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory - [ true false ]. diff --git a/contrib/ring/LegacyRing_theory.v b/contrib/ring/LegacyRing_theory.v deleted file mode 100644 index d15d18a6..00000000 --- a/contrib/ring/LegacyRing_theory.v +++ /dev/null @@ -1,376 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *) - -Require Export Bool. - -Set Implicit Arguments. - -Section Theory_of_semi_rings. - -Variable A : Type. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -(* There is also a "weakly decidable" equality on A. That means - that if (A_eq x y)=true then x=y but x=y can arise when - (A_eq x y)=false. On an abstract ring the function [x,y:A]false - is a good choice. The proof of A_eq_prop is in this case easy. *) -Variable Aeq : A -> A -> bool. - -Infix "+" := Aplus (at level 50, left associativity). -Infix "*" := Amult (at level 40, left associativity). -Notation "0" := Azero. -Notation "1" := Aone. - -Record Semi_Ring_Theory : Prop := - {SR_plus_comm : forall n m:A, n + m = m + n; - SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; - SR_mult_comm : forall n m:A, n * m = m * n; - SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; - SR_plus_zero_left : forall n:A, 0 + n = n; - SR_mult_one_left : forall n:A, 1 * n = n; - SR_mult_zero_left : forall n:A, 0 * n = 0; - SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; -(* SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*) - SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. - -Variable T : Semi_Ring_Theory. - -Let plus_comm := SR_plus_comm T. -Let plus_assoc := SR_plus_assoc T. -Let mult_comm := SR_mult_comm T. -Let mult_assoc := SR_mult_assoc T. -Let plus_zero_left := SR_plus_zero_left T. -Let mult_one_left := SR_mult_one_left T. -Let mult_zero_left := SR_mult_zero_left T. -Let distr_left := SR_distr_left T. -(*Let plus_reg_left := SR_plus_reg_left T.*) - -Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left - mult_one_left mult_zero_left distr_left (*plus_reg_left*). - -(* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) -Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). -symmetry in |- *; eauto. Qed. - -Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry in |- *; eauto. Qed. - -Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry in |- *; eauto. Qed. - -Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. -symmetry in |- *; eauto. Qed. - -Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. -symmetry in |- *; eauto. Qed. - -Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry in |- *; eauto. Qed. - -Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). -intros. -rewrite plus_assoc. -elim (plus_comm m n). -rewrite <- plus_assoc. -reflexivity. -Qed. - -Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). -intros. -rewrite mult_assoc. -elim (mult_comm m n). -rewrite <- mult_assoc. -reflexivity. -Qed. - -Hint Resolve SR_plus_permute SR_mult_permute. - -Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. -intros. -repeat rewrite (mult_comm n). -eauto. -Qed. - -Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). -symmetry in |- *; apply SR_distr_right. Qed. - -Lemma SR_mult_zero_right : forall n:A, n * 0 = 0. -intro; rewrite mult_comm; eauto. -Qed. - -Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0. -intro; rewrite mult_comm; eauto. -Qed. - -Lemma SR_plus_zero_right : forall n:A, n + 0 = n. -intro; rewrite plus_comm; eauto. -Qed. -Lemma SR_plus_zero_right2 : forall n:A, n = n + 0. -intro; rewrite plus_comm; eauto. -Qed. - -Lemma SR_mult_one_right : forall n:A, n * 1 = n. -intro; elim mult_comm; auto. -Qed. - -Lemma SR_mult_one_right2 : forall n:A, n = n * 1. -intro; elim mult_comm; auto. -Qed. -(* -Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. -intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto. -Qed. -*) -End Theory_of_semi_rings. - -Section Theory_of_rings. - -Variable A : Type. - -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. - -Infix "+" := Aplus (at level 50, left associativity). -Infix "*" := Amult (at level 40, left associativity). -Notation "0" := Azero. -Notation "1" := Aone. -Notation "- x" := (Aopp x). - -Record Ring_Theory : Prop := - {Th_plus_comm : forall n m:A, n + m = m + n; - Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; - Th_mult_comm : forall n m:A, n * m = m * n; - Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; - Th_plus_zero_left : forall n:A, 0 + n = n; - Th_mult_one_left : forall n:A, 1 * n = n; - Th_opp_def : forall n:A, n + - n = 0; - Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; - Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. - -Variable T : Ring_Theory. - -Let plus_comm := Th_plus_comm T. -Let plus_assoc := Th_plus_assoc T. -Let mult_comm := Th_mult_comm T. -Let mult_assoc := Th_mult_assoc T. -Let plus_zero_left := Th_plus_zero_left T. -Let mult_one_left := Th_mult_one_left T. -Let opp_def := Th_opp_def T. -Let distr_left := Th_distr_left T. - -Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left - mult_one_left opp_def distr_left. - -(* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) -Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). -symmetry in |- *; eauto. Qed. - -Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry in |- *; eauto. Qed. - -Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry in |- *; eauto. Qed. - -Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. -symmetry in |- *; eauto. Qed. - -Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry in |- *; eauto. Qed. - -Lemma Th_opp_def2 : forall n:A, 0 = n + - n. -symmetry in |- *; eauto. Qed. - -Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). -intros. -rewrite plus_assoc. -elim (plus_comm m n). -rewrite <- plus_assoc. -reflexivity. -Qed. - -Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). -intros. -rewrite mult_assoc. -elim (mult_comm m n). -rewrite <- mult_assoc. -reflexivity. -Qed. - -Hint Resolve Th_plus_permute Th_mult_permute. - -Lemma aux1 : forall a:A, a + a = a -> a = 0. -intros. -generalize (opp_def a). -pattern a at 1 in |- *. -rewrite <- H. -rewrite <- plus_assoc. -rewrite opp_def. -elim plus_comm. -rewrite plus_zero_left. -trivial. -Qed. - -Lemma Th_mult_zero_left : forall n:A, 0 * n = 0. -intros. -apply aux1. -rewrite <- distr_left. -rewrite plus_zero_left. -reflexivity. -Qed. -Hint Resolve Th_mult_zero_left. - -Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n. -symmetry in |- *; eauto. Qed. - -Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z. -intros. -rewrite <- (plus_zero_left y). -elim H0. -elim plus_assoc. -elim (plus_comm y z). -rewrite plus_assoc. -rewrite H. -rewrite plus_zero_left. -reflexivity. -Qed. - -Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y. -intros. -apply (aux2 (x:=(x * y))); - [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ]. -Qed. -Hint Resolve Th_opp_mult_left. - -Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y). -symmetry in |- *; eauto. Qed. - -Lemma Th_mult_zero_right : forall n:A, n * 0 = 0. -intro; elim mult_comm; eauto. -Qed. - -Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0. -intro; elim mult_comm; eauto. -Qed. - -Lemma Th_plus_zero_right : forall n:A, n + 0 = n. -intro; rewrite plus_comm; eauto. -Qed. - -Lemma Th_plus_zero_right2 : forall n:A, n = n + 0. -intro; rewrite plus_comm; eauto. -Qed. - -Lemma Th_mult_one_right : forall n:A, n * 1 = n. -intro; elim mult_comm; eauto. -Qed. - -Lemma Th_mult_one_right2 : forall n:A, n = n * 1. -intro; elim mult_comm; eauto. -Qed. - -Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y. -intros; do 2 rewrite (mult_comm x); auto. -Qed. - -Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y). -intros; do 2 rewrite (mult_comm x); auto. -Qed. - -Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y). -intros. -apply (aux2 (x:=(x + y))); - [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc; - rewrite opp_def; rewrite plus_zero_left; auto - | auto ]. -Qed. - -Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p). -eauto. Qed. - -Lemma Th_opp_opp : forall n:A, - - n = n. -intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ]. -Qed. -Hint Resolve Th_opp_opp. - -Lemma Th_opp_opp2 : forall n:A, n = - - n. -symmetry in |- *; eauto. Qed. - -Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y. -intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto. -Qed. - -Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y. -symmetry in |- *; apply Th_mult_opp_opp. Qed. - -Lemma Th_opp_zero : - 0 = 0. -rewrite <- (plus_zero_left (- 0)). -auto. Qed. -(* -Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p. -intros; generalize (f_equal (fun z => - n + z) H). -repeat rewrite plus_assoc. -rewrite (plus_comm (- n) n). -rewrite opp_def. -repeat rewrite Th_plus_zero_left; eauto. -Qed. - -Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. -intros. -eapply Th_plus_reg_left with n. -rewrite (plus_comm n m). -rewrite (plus_comm n p). -auto. -Qed. -*) -Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. -intros. -repeat rewrite (mult_comm n). -eauto. -Qed. - -Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). -symmetry in |- *; apply Th_distr_right. -Qed. - -End Theory_of_rings. - -Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. - -Unset Implicit Arguments. - -Definition Semi_Ring_Theory_of : - forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) - (Aopp:A -> A) (Aeq:A -> A -> bool), - Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> - Semi_Ring_Theory Aplus Amult Aone Azero Aeq. -intros until 1; case H. -split; intros; simpl in |- *; eauto. -Defined. - -(* Every ring can be viewed as a semi-ring : this property will be used - in Abstract_polynom. *) -Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory. - - -Section product_ring. - -End product_ring. - -Section power_ring. - -End power_ring. diff --git a/contrib/ring/LegacyZArithRing.v b/contrib/ring/LegacyZArithRing.v deleted file mode 100644 index a410fbc5..00000000 --- a/contrib/ring/LegacyZArithRing.v +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *) - -(* Instantiation of the Ring tactic for the binary integers of ZArith *) - -Require Export LegacyArithRing. -Require Export ZArith_base. -Require Import Eqdep_dec. -Require Import LegacyRing. - -Unboxed Definition Zeq (x y:Z) := - match (x ?= y)%Z with - | Datatypes.Eq => true - | _ => false - end. - -Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. - intros x y H; unfold Zeq in H. - apply Zcompare_Eq_eq. - destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. -Qed. - -Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. - split; intros; eauto with zarith. - apply Zeq_prop; assumption. -Qed. - -(* NatConstants and NatTheory are defined in Ring_theory.v *) -Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory - [ Zpos Zneg 0%Z xO xI 1%positive ]. diff --git a/contrib/ring/Quote.v b/contrib/ring/Quote.v deleted file mode 100644 index 6f7414a3..00000000 --- a/contrib/ring/Quote.v +++ /dev/null @@ -1,85 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Quote.v 6295 2004-11-12 16:40:39Z gregoire $ *) - -(*********************************************************************** - The "abstract" type index is defined to represent variables. - - index : Set - index_eq : index -> bool - index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m - index_lt : index -> bool - varmap : Type -> Type. - varmap_find : (A:Type)A -> index -> (varmap A) -> A. - - The first arg. of varmap_find is the default value to take - if the object is not found in the varmap. - - index_lt defines a total well-founded order, but we don't prove that. - -***********************************************************************) - -Set Implicit Arguments. -Unset Boxed Definitions. - -Section variables_map. - -Variable A : Type. - -Inductive varmap : Type := - | Empty_vm : varmap - | Node_vm : A -> varmap -> varmap -> varmap. - -Inductive index : Set := - | Left_idx : index -> index - | Right_idx : index -> index - | End_idx : index. - -Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := - match i, v with - | End_idx, Node_vm x _ _ => x - | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 - | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 - | _, _ => default_value - end. - -Fixpoint index_eq (n m:index) {struct m} : bool := - match n, m with - | End_idx, End_idx => true - | Left_idx n', Left_idx m' => index_eq n' m' - | Right_idx n', Right_idx m' => index_eq n' m' - | _, _ => false - end. - -Fixpoint index_lt (n m:index) {struct m} : bool := - match n, m with - | End_idx, Left_idx _ => true - | End_idx, Right_idx _ => true - | Left_idx n', Right_idx m' => true - | Right_idx n', Right_idx m' => index_lt n' m' - | Left_idx n', Left_idx m' => index_lt n' m' - | _, _ => false - end. - -Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. - simple induction n; simple induction m; simpl in |- *; intros. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - rewrite (H i0 H1); reflexivity. - discriminate. - discriminate. - discriminate. - reflexivity. -Qed. - -End variables_map. - -Unset Implicit Arguments. diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v deleted file mode 100644 index c2467ebf..00000000 --- a/contrib/ring/Ring_abstract.v +++ /dev/null @@ -1,706 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *) - -Require Import LegacyRing_theory. -Require Import Quote. -Require Import Ring_normalize. - -Unset Boxed Definitions. - -Section abstract_semi_rings. - -Inductive aspolynomial : Type := - | ASPvar : index -> aspolynomial - | ASP0 : aspolynomial - | ASP1 : aspolynomial - | ASPplus : aspolynomial -> aspolynomial -> aspolynomial - | ASPmult : aspolynomial -> aspolynomial -> aspolynomial. - -Inductive abstract_sum : Type := - | Nil_acs : abstract_sum - | Cons_acs : varlist -> abstract_sum -> abstract_sum. - -Fixpoint abstract_sum_merge (s1:abstract_sum) : - abstract_sum -> abstract_sum := - match s1 with - | Cons_acs l1 t1 => - (fix asm_aux (s2:abstract_sum) : abstract_sum := - match s2 with - | Cons_acs l2 t2 => - if varlist_lt l1 l2 - then Cons_acs l1 (abstract_sum_merge t1 s2) - else Cons_acs l2 (asm_aux t2) - | Nil_acs => s1 - end) - | Nil_acs => fun s2 => s2 - end. - -Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} : - abstract_sum := - match s2 with - | Cons_acs l2 t2 => - if varlist_lt l1 l2 - then Cons_acs l1 s2 - else Cons_acs l2 (abstract_varlist_insert l1 t2) - | Nil_acs => Cons_acs l1 Nil_acs - end. - -Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} : - abstract_sum := - match s2 with - | Cons_acs l2 t2 => - abstract_varlist_insert (varlist_merge l1 l2) - (abstract_sum_scalar l1 t2) - | Nil_acs => Nil_acs - end. - -Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum := - match s1 with - | Cons_acs l1 t1 => - abstract_sum_merge (abstract_sum_scalar l1 s2) - (abstract_sum_prod t1 s2) - | Nil_acs => Nil_acs - end. - -Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum := - match p with - | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs - | ASP1 => Cons_acs Nil_var Nil_acs - | ASP0 => Nil_acs - | ASPplus l r => - abstract_sum_merge (aspolynomial_normalize l) - (aspolynomial_normalize r) - | ASPmult l r => - abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r) - end. - - - -Variable A : Type. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aeq : A -> A -> bool. -Variable vm : varmap A. -Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. - -Fixpoint interp_asp (p:aspolynomial) : A := - match p with - | ASPvar i => interp_var Azero vm i - | ASP0 => Azero - | ASP1 => Aone - | ASPplus l r => Aplus (interp_asp l) (interp_asp r) - | ASPmult l r => Amult (interp_asp l) (interp_asp r) - end. - -(* Local *) Definition iacs_aux := - (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A := - match s with - | Nil_acs => a - | Cons_acs l t => - Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t) - end). - -Definition interp_acs (s:abstract_sum) : A := - match s with - | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t - | Nil_acs => Azero - end. - -Hint Resolve (SR_plus_comm T). -Hint Resolve (SR_plus_assoc T). -Hint Resolve (SR_plus_assoc2 T). -Hint Resolve (SR_mult_comm T). -Hint Resolve (SR_mult_assoc T). -Hint Resolve (SR_mult_assoc2 T). -Hint Resolve (SR_plus_zero_left T). -Hint Resolve (SR_plus_zero_left2 T). -Hint Resolve (SR_mult_one_left T). -Hint Resolve (SR_mult_one_left2 T). -Hint Resolve (SR_mult_zero_left T). -Hint Resolve (SR_mult_zero_left2 T). -Hint Resolve (SR_distr_left T). -Hint Resolve (SR_distr_left2 T). -(*Hint Resolve (SR_plus_reg_left T).*) -Hint Resolve (SR_plus_permute T). -Hint Resolve (SR_mult_permute T). -Hint Resolve (SR_distr_right T). -Hint Resolve (SR_distr_right2 T). -Hint Resolve (SR_mult_zero_right T). -Hint Resolve (SR_mult_zero_right2 T). -Hint Resolve (SR_plus_zero_right T). -Hint Resolve (SR_plus_zero_right2 T). -Hint Resolve (SR_mult_one_right T). -Hint Resolve (SR_mult_one_right2 T). -(*Hint Resolve (SR_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) -Hint Immediate T. - -Remark iacs_aux_ok : - forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s). -Proof. - simple induction s; simpl in |- *; intros. - trivial. - reflexivity. -Qed. - -Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core. - -Lemma abstract_varlist_insert_ok : - forall (l:varlist) (s:abstract_sum), - interp_acs (abstract_varlist_insert l s) = - Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s). - - simple induction s. - trivial. - - simpl in |- *; intros. - elim (varlist_lt l v); simpl in |- *. - eauto. - rewrite iacs_aux_ok. - rewrite H; auto. - -Qed. - -Lemma abstract_sum_merge_ok : - forall x y:abstract_sum, - interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). - -Proof. - simple induction x. - trivial. - simple induction y; intros. - - auto. - - simpl in |- *; elim (varlist_lt v v0); simpl in |- *. - repeat rewrite iacs_aux_ok. - rewrite H; simpl in |- *; auto. - - simpl in H0. - repeat rewrite iacs_aux_ok. - rewrite H0. simpl in |- *; auto. -Qed. - -Lemma abstract_sum_scalar_ok : - forall (l:varlist) (s:abstract_sum), - interp_acs (abstract_sum_scalar l s) = - Amult (interp_vl Amult Aone Azero vm l) (interp_acs s). -Proof. - simple induction s. - simpl in |- *; eauto. - - simpl in |- *; intros. - rewrite iacs_aux_ok. - rewrite abstract_varlist_insert_ok. - rewrite H. - rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). - auto. -Qed. - -Lemma abstract_sum_prod_ok : - forall x y:abstract_sum, - interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y). - -Proof. - simple induction x. - intros; simpl in |- *; eauto. - - destruct y as [| v0 a0]; intros. - - simpl in |- *; rewrite H; eauto. - - unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *. - rewrite abstract_sum_merge_ok. - rewrite abstract_sum_scalar_ok. - rewrite H; simpl in |- *; auto. -Qed. - -Theorem aspolynomial_normalize_ok : - forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). -Proof. - simple induction x; simpl in |- *; intros; trivial. - rewrite abstract_sum_merge_ok. - rewrite H; rewrite H0; eauto. - rewrite abstract_sum_prod_ok. - rewrite H; rewrite H0; eauto. -Qed. - -End abstract_semi_rings. - -Section abstract_rings. - -(* In abstract polynomials there is no constants other - than 0 and 1. An abstract ring is a ring whose operations plus, - and mult are not functions but constructors. In other words, - when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed - term. "closed" mean here "without plus and mult". *) - -(* this section is not parametrized by a (semi-)ring. - Nevertheless, they are two different types for semi-rings and rings - and there will be 2 correction theorems *) - -Inductive apolynomial : Type := - | APvar : index -> apolynomial - | AP0 : apolynomial - | AP1 : apolynomial - | APplus : apolynomial -> apolynomial -> apolynomial - | APmult : apolynomial -> apolynomial -> apolynomial - | APopp : apolynomial -> apolynomial. - -(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-". - Invariant : the list is sorted and there is no varlist is present - with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *) - -Inductive signed_sum : Type := - | Nil_varlist : signed_sum - | Plus_varlist : varlist -> signed_sum -> signed_sum - | Minus_varlist : varlist -> signed_sum -> signed_sum. - -Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum := - match s1 with - | Plus_varlist l1 t1 => - (fix ssm_aux (s2:signed_sum) : signed_sum := - match s2 with - | Plus_varlist l2 t2 => - if varlist_lt l1 l2 - then Plus_varlist l1 (signed_sum_merge t1 s2) - else Plus_varlist l2 (ssm_aux t2) - | Minus_varlist l2 t2 => - if varlist_eq l1 l2 - then signed_sum_merge t1 t2 - else - if varlist_lt l1 l2 - then Plus_varlist l1 (signed_sum_merge t1 s2) - else Minus_varlist l2 (ssm_aux t2) - | Nil_varlist => s1 - end) - | Minus_varlist l1 t1 => - (fix ssm_aux2 (s2:signed_sum) : signed_sum := - match s2 with - | Plus_varlist l2 t2 => - if varlist_eq l1 l2 - then signed_sum_merge t1 t2 - else - if varlist_lt l1 l2 - then Minus_varlist l1 (signed_sum_merge t1 s2) - else Plus_varlist l2 (ssm_aux2 t2) - | Minus_varlist l2 t2 => - if varlist_lt l1 l2 - then Minus_varlist l1 (signed_sum_merge t1 s2) - else Minus_varlist l2 (ssm_aux2 t2) - | Nil_varlist => s1 - end) - | Nil_varlist => fun s2 => s2 - end. - -Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : - signed_sum := - match s2 with - | Plus_varlist l2 t2 => - if varlist_lt l1 l2 - then Plus_varlist l1 s2 - else Plus_varlist l2 (plus_varlist_insert l1 t2) - | Minus_varlist l2 t2 => - if varlist_eq l1 l2 - then t2 - else - if varlist_lt l1 l2 - then Plus_varlist l1 s2 - else Minus_varlist l2 (plus_varlist_insert l1 t2) - | Nil_varlist => Plus_varlist l1 Nil_varlist - end. - -Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : - signed_sum := - match s2 with - | Plus_varlist l2 t2 => - if varlist_eq l1 l2 - then t2 - else - if varlist_lt l1 l2 - then Minus_varlist l1 s2 - else Plus_varlist l2 (minus_varlist_insert l1 t2) - | Minus_varlist l2 t2 => - if varlist_lt l1 l2 - then Minus_varlist l1 s2 - else Minus_varlist l2 (minus_varlist_insert l1 t2) - | Nil_varlist => Minus_varlist l1 Nil_varlist - end. - -Fixpoint signed_sum_opp (s:signed_sum) : signed_sum := - match s with - | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2) - | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2) - | Nil_varlist => Nil_varlist - end. - - -Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : - signed_sum := - match s2 with - | Plus_varlist l2 t2 => - plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) - | Minus_varlist l2 t2 => - minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) - | Nil_varlist => Nil_varlist - end. - -Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : - signed_sum := - match s2 with - | Plus_varlist l2 t2 => - minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) - | Minus_varlist l2 t2 => - plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) - | Nil_varlist => Nil_varlist - end. - -Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum := - match s1 with - | Plus_varlist l1 t1 => - signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2) - | Minus_varlist l1 t1 => - signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2) - | Nil_varlist => Nil_varlist - end. - -Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum := - match p with - | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist - | AP1 => Plus_varlist Nil_var Nil_varlist - | AP0 => Nil_varlist - | APplus l r => - signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r) - | APmult l r => - signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r) - | APopp q => signed_sum_opp (apolynomial_normalize q) - end. - - -Variable A : Type. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. -Variable vm : varmap A. -Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. - -(* Local *) Definition isacs_aux := - (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A := - match s with - | Nil_varlist => a - | Plus_varlist l t => - Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t) - | Minus_varlist l t => - Aplus a - (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t) - end). - -Definition interp_sacs (s:signed_sum) : A := - match s with - | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t - | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t - | Nil_varlist => Azero - end. - -Fixpoint interp_ap (p:apolynomial) : A := - match p with - | APvar i => interp_var Azero vm i - | AP0 => Azero - | AP1 => Aone - | APplus l r => Aplus (interp_ap l) (interp_ap r) - | APmult l r => Amult (interp_ap l) (interp_ap r) - | APopp q => Aopp (interp_ap q) - end. - -Hint Resolve (Th_plus_comm T). -Hint Resolve (Th_plus_assoc T). -Hint Resolve (Th_plus_assoc2 T). -Hint Resolve (Th_mult_comm T). -Hint Resolve (Th_mult_assoc T). -Hint Resolve (Th_mult_assoc2 T). -Hint Resolve (Th_plus_zero_left T). -Hint Resolve (Th_plus_zero_left2 T). -Hint Resolve (Th_mult_one_left T). -Hint Resolve (Th_mult_one_left2 T). -Hint Resolve (Th_mult_zero_left T). -Hint Resolve (Th_mult_zero_left2 T). -Hint Resolve (Th_distr_left T). -Hint Resolve (Th_distr_left2 T). -(*Hint Resolve (Th_plus_reg_left T).*) -Hint Resolve (Th_plus_permute T). -Hint Resolve (Th_mult_permute T). -Hint Resolve (Th_distr_right T). -Hint Resolve (Th_distr_right2 T). -Hint Resolve (Th_mult_zero_right2 T). -Hint Resolve (Th_plus_zero_right T). -Hint Resolve (Th_plus_zero_right2 T). -Hint Resolve (Th_mult_one_right T). -Hint Resolve (Th_mult_one_right2 T). -(*Hint Resolve (Th_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) -Hint Immediate T. - -Lemma isacs_aux_ok : - forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s). -Proof. - simple induction s; simpl in |- *; intros. - trivial. - reflexivity. - reflexivity. -Qed. - -Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. - -Ltac solve1 v v0 H H0 := - simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok; - [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ]. - -Lemma signed_sum_merge_ok : - forall x y:signed_sum, - interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y). - - simple induction x. - intro; simpl in |- *; auto. - - simple induction y; intros. - - auto. - - solve1 v v0 H H0. - - simpl in |- *; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl in |- *. - - intro Heq; rewrite (Heq I). - rewrite H. - repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). - repeat rewrite (Th_plus_assoc T). - rewrite - (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) - (interp_vl Amult Aone Azero vm v0)). - rewrite (Th_opp_def T). - rewrite (Th_plus_zero_left T). - reflexivity. - - solve1 v v0 H H0. - - simple induction y; intros. - - auto. - - simpl in |- *; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl in |- *. - - intro Heq; rewrite (Heq I). - rewrite H. - repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). - repeat rewrite (Th_plus_assoc T). - rewrite (Th_opp_def T). - rewrite (Th_plus_zero_left T). - reflexivity. - - solve1 v v0 H H0. - - solve1 v v0 H H0. - -Qed. - -Ltac solve2 l v H := - elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok; - [ auto | rewrite H; auto ]. - -Lemma plus_varlist_insert_ok : - forall (l:varlist) (s:signed_sum), - interp_sacs (plus_varlist_insert l s) = - Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s). -Proof. - - simple induction s. - trivial. - - simpl in |- *; intros. - solve2 l v H. - - simpl in |- *; intros. - generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl in |- *. - - intro Heq; rewrite (Heq I). - repeat rewrite isacs_aux_ok. - repeat rewrite (Th_plus_assoc T). - rewrite (Th_opp_def T). - rewrite (Th_plus_zero_left T). - reflexivity. - - solve2 l v H. - -Qed. - -Lemma minus_varlist_insert_ok : - forall (l:varlist) (s:signed_sum), - interp_sacs (minus_varlist_insert l s) = - Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s). -Proof. - - simple induction s. - trivial. - - simpl in |- *; intros. - generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl in |- *. - - intro Heq; rewrite (Heq I). - repeat rewrite isacs_aux_ok. - repeat rewrite (Th_plus_assoc T). - rewrite - (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v)) - (interp_vl Amult Aone Azero vm v)). - rewrite (Th_opp_def T). - auto. - - simpl in |- *; intros. - solve2 l v H. - - simpl in |- *; intros; solve2 l v H. - -Qed. - -Lemma signed_sum_opp_ok : - forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s). -Proof. - - simple induction s; simpl in |- *; intros. - - symmetry in |- *; apply (Th_opp_zero T). - - repeat rewrite isacs_aux_ok. - rewrite H. - rewrite (Th_plus_opp_opp T). - reflexivity. - - repeat rewrite isacs_aux_ok. - rewrite H. - rewrite <- (Th_plus_opp_opp T). - rewrite (Th_opp_opp T). - reflexivity. - -Qed. - -Lemma plus_sum_scalar_ok : - forall (l:varlist) (s:signed_sum), - interp_sacs (plus_sum_scalar l s) = - Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s). -Proof. - - simple induction s. - trivial. - - simpl in |- *; intros. - rewrite plus_varlist_insert_ok. - rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). - repeat rewrite isacs_aux_ok. - rewrite H. - auto. - - simpl in |- *; intros. - rewrite minus_varlist_insert_ok. - repeat rewrite isacs_aux_ok. - rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). - rewrite H. - rewrite (Th_distr_right T). - rewrite <- (Th_opp_mult_right T). - reflexivity. - -Qed. - -Lemma minus_sum_scalar_ok : - forall (l:varlist) (s:signed_sum), - interp_sacs (minus_sum_scalar l s) = - Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)). -Proof. - - simple induction s; simpl in |- *; intros. - - rewrite (Th_mult_zero_right T); symmetry in |- *; apply (Th_opp_zero T). - - simpl in |- *; intros. - rewrite minus_varlist_insert_ok. - rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). - repeat rewrite isacs_aux_ok. - rewrite H. - rewrite (Th_distr_right T). - rewrite (Th_plus_opp_opp T). - reflexivity. - - simpl in |- *; intros. - rewrite plus_varlist_insert_ok. - repeat rewrite isacs_aux_ok. - rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). - rewrite H. - rewrite (Th_distr_right T). - rewrite <- (Th_opp_mult_right T). - rewrite <- (Th_plus_opp_opp T). - rewrite (Th_opp_opp T). - reflexivity. - -Qed. - -Lemma signed_sum_prod_ok : - forall x y:signed_sum, - interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y). -Proof. - - simple induction x. - - simpl in |- *; eauto 1. - - intros; simpl in |- *. - rewrite signed_sum_merge_ok. - rewrite plus_sum_scalar_ok. - repeat rewrite isacs_aux_ok. - rewrite H. - auto. - - intros; simpl in |- *. - repeat rewrite isacs_aux_ok. - rewrite signed_sum_merge_ok. - rewrite minus_sum_scalar_ok. - rewrite H. - rewrite (Th_distr_left T). - rewrite (Th_opp_mult_left T). - reflexivity. - -Qed. - -Theorem apolynomial_normalize_ok : - forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p. -Proof. - simple induction p; simpl in |- *; auto 1. - intros. - rewrite signed_sum_merge_ok. - rewrite H; rewrite H0; reflexivity. - intros. - rewrite signed_sum_prod_ok. - rewrite H; rewrite H0; reflexivity. - intros. - rewrite signed_sum_opp_ok. - rewrite H; reflexivity. -Qed. - -End abstract_rings. diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v deleted file mode 100644 index e8d9f1ee..00000000 --- a/contrib/ring/Ring_normalize.v +++ /dev/null @@ -1,902 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *) - -Require Import LegacyRing_theory. -Require Import Quote. - -Set Implicit Arguments. -Unset Boxed Definitions. - -Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. -Proof. - intros. - apply index_eq_prop. - generalize H. - case (index_eq n m); simpl in |- *; trivial; intros. - contradiction. -Qed. - -Section semi_rings. - -Variable A : Type. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aeq : A -> A -> bool. - -(* Section definitions. *) - - -(******************************************) -(* Normal abtract Polynomials *) -(******************************************) -(* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z -- A monom is a constant, a varlist or the product of a constant by a varlist - variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) -- A normal polynomial it either a constant or a canonical sum or a constant - plus a canonical sum -*) - -(* varlist is isomorphic to (list var), but we built a special inductive - for efficiency *) -Inductive varlist : Type := - | Nil_var : varlist - | Cons_var : index -> varlist -> varlist. - -Inductive canonical_sum : Type := - | Nil_monom : canonical_sum - | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum - | Cons_varlist : varlist -> canonical_sum -> canonical_sum. - -(* Order on monoms *) - -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom - - The relation between two varlist is preserved by multiplication by a - constant. - - Examples : - 3 < x < y - x*y < x*y*y*z - 2*x*y < x*y*y*z - x*y < 54*x*y*y*z - 4*x*y < 59*x*y*y*z -*) - -Fixpoint varlist_eq (x y:varlist) {struct y} : bool := - match x, y with - | Nil_var, Nil_var => true - | Cons_var i xrest, Cons_var j yrest => - andb (index_eq i j) (varlist_eq xrest yrest) - | _, _ => false - end. - -Fixpoint varlist_lt (x y:varlist) {struct y} : bool := - match x, y with - | Nil_var, Cons_var _ _ => true - | Cons_var i xrest, Cons_var j yrest => - if index_lt i j - then true - else andb (index_eq i j) (varlist_lt xrest yrest) - | _, _ => false - end. - -(* merges two variables lists *) -Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := - match l1 with - | Cons_var v1 t1 => - (fix vm_aux (l2:varlist) : varlist := - match l2 with - | Cons_var v2 t2 => - if index_lt v1 v2 - then Cons_var v1 (varlist_merge t1 l2) - else Cons_var v2 (vm_aux t2) - | Nil_var => l1 - end) - | Nil_var => fun l2 => l2 - end. - -(* returns the sum of two canonical sums *) -Fixpoint canonical_sum_merge (s1:canonical_sum) : - canonical_sum -> canonical_sum := - match s1 with - | Cons_monom c1 l1 t1 => - (fix csm_aux (s2:canonical_sum) : canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 (canonical_sum_merge t1 s2) - else Cons_monom c2 l2 (csm_aux t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 (canonical_sum_merge t1 s2) - else Cons_varlist l2 (csm_aux t2) - | Nil_monom => s1 - end) - | Cons_varlist l1 t1 => - (fix csm_aux2 (s2:canonical_sum) : canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_varlist l1 (canonical_sum_merge t1 s2) - else Cons_monom c2 l2 (csm_aux2 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_varlist l1 (canonical_sum_merge t1 s2) - else Cons_varlist l2 (csm_aux2 t2) - | Nil_monom => s1 - end) - | Nil_monom => fun s2 => s2 - end. - -(* Insertion of a monom in a canonical sum *) -Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : - canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 c2) l1 t2 - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 s2 - else Cons_monom c2 l2 (monom_insert c1 l1 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 Aone) l1 t2 - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 s2 - else Cons_varlist l2 (monom_insert c1 l1 t2) - | Nil_monom => Cons_monom c1 l1 Nil_monom - end. - -Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : - canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone c2) l1 t2 - else - if varlist_lt l1 l2 - then Cons_varlist l1 s2 - else Cons_monom c2 l2 (varlist_insert l1 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone Aone) l1 t2 - else - if varlist_lt l1 l2 - then Cons_varlist l1 s2 - else Cons_varlist l2 (varlist_insert l1 t2) - | Nil_monom => Cons_varlist l1 Nil_monom - end. - -(* Computes c0*s *) -Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : - canonical_sum := - match s with - | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) - | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) - | Nil_monom => Nil_monom - end. - -(* Computes l0*s *) -Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : - canonical_sum := - match s with - | Cons_monom c l t => - monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) - | Cons_varlist l t => - varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) - | Nil_monom => Nil_monom - end. - -(* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) - (s:canonical_sum) {struct s} : canonical_sum := - match s with - | Cons_monom c l t => - monom_insert (Amult c0 c) (varlist_merge l0 l) - (canonical_sum_scalar3 c0 l0 t) - | Cons_varlist l t => - monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) - | Nil_monom => Nil_monom - end. - -(* returns the product of two canonical sums *) -Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : - canonical_sum := - match s1 with - | Cons_monom c1 l1 t1 => - canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) - (canonical_sum_prod t1 s2) - | Cons_varlist l1 t1 => - canonical_sum_merge (canonical_sum_scalar2 l1 s2) - (canonical_sum_prod t1 s2) - | Nil_monom => Nil_monom - end. - -(* The type to represent concrete semi-ring polynomials *) -Inductive spolynomial : Type := - | SPvar : index -> spolynomial - | SPconst : A -> spolynomial - | SPplus : spolynomial -> spolynomial -> spolynomial - | SPmult : spolynomial -> spolynomial -> spolynomial. - -Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum := - match p with - | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom - | SPconst c => Cons_monom c Nil_var Nil_monom - | SPplus l r => - canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r) - | SPmult l r => - canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r) - end. - -(* Deletion of useless 0 and 1 in canonical sums *) -Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := - match s with - | Cons_monom c l t => - if Aeq c Azero - then canonical_sum_simplify t - else - if Aeq c Aone - then Cons_varlist l (canonical_sum_simplify t) - else Cons_monom c l (canonical_sum_simplify t) - | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) - | Nil_monom => Nil_monom - end. - -Definition spolynomial_simplify (x:spolynomial) := - canonical_sum_simplify (spolynomial_normalize x). - -(* End definitions. *) - -(* Section interpretation. *) - -(*** Here a variable map is defined and the interpetation of a spolynom - acording to a certain variables map. Once again the choosen definition - is generic and could be changed ****) - -Variable vm : varmap A. - -(* Interpretation of list of variables - * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) - * The unbound variables are mapped to 0. Normally this case sould - * never occur. Since we want only to prove correctness theorems, which form - * is : for any varmap and any spolynom ... this is a safe and pain-saving - * choice *) -Definition interp_var (i:index) := varmap_find Azero i vm. - -(* Local *) Definition ivl_aux := - (fix ivl_aux (x:index) (t:varlist) {struct t} : A := - match t with - | Nil_var => interp_var x - | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') - end). - -Definition interp_vl (l:varlist) := - match l with - | Nil_var => Aone - | Cons_var x t => ivl_aux x t - end. - -(* Local *) Definition interp_m (c:A) (l:varlist) := - match l with - | Nil_var => c - | Cons_var x t => Amult c (ivl_aux x t) - end. - -(* Local *) Definition ics_aux := - (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := - match s with - | Nil_monom => a - | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) - | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) - end). - -(* Interpretation of a canonical sum *) -Definition interp_cs (s:canonical_sum) : A := - match s with - | Nil_monom => Azero - | Cons_varlist l t => ics_aux (interp_vl l) t - | Cons_monom c l t => ics_aux (interp_m c l) t - end. - -Fixpoint interp_sp (p:spolynomial) : A := - match p with - | SPconst c => c - | SPvar i => interp_var i - | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2) - | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2) - end. - - -(* End interpretation. *) - -Unset Implicit Arguments. - -(* Section properties. *) - -Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. - -Hint Resolve (SR_plus_comm T). -Hint Resolve (SR_plus_assoc T). -Hint Resolve (SR_plus_assoc2 T). -Hint Resolve (SR_mult_comm T). -Hint Resolve (SR_mult_assoc T). -Hint Resolve (SR_mult_assoc2 T). -Hint Resolve (SR_plus_zero_left T). -Hint Resolve (SR_plus_zero_left2 T). -Hint Resolve (SR_mult_one_left T). -Hint Resolve (SR_mult_one_left2 T). -Hint Resolve (SR_mult_zero_left T). -Hint Resolve (SR_mult_zero_left2 T). -Hint Resolve (SR_distr_left T). -Hint Resolve (SR_distr_left2 T). -(*Hint Resolve (SR_plus_reg_left T).*) -Hint Resolve (SR_plus_permute T). -Hint Resolve (SR_mult_permute T). -Hint Resolve (SR_distr_right T). -Hint Resolve (SR_distr_right2 T). -Hint Resolve (SR_mult_zero_right T). -Hint Resolve (SR_mult_zero_right2 T). -Hint Resolve (SR_plus_zero_right T). -Hint Resolve (SR_plus_zero_right2 T). -Hint Resolve (SR_mult_one_right T). -Hint Resolve (SR_mult_one_right2 T). -(*Hint Resolve (SR_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(* Hints Resolve refl_eqT sym_eqT trans_eqT. *) -Hint Immediate T. - -Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. -Proof. - simple induction x; simple induction y; contradiction || (try reflexivity). - simpl in |- *; intros. - generalize (andb_prop2 _ _ H1); intros; elim H2; intros. - rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. -Qed. - -Remark ivl_aux_ok : - forall (v:varlist) (i:index), - ivl_aux i v = Amult (interp_var i) (interp_vl v). -Proof. - simple induction v; simpl in |- *; intros. - trivial. - rewrite H; trivial. -Qed. - -Lemma varlist_merge_ok : - forall x y:varlist, - interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y). -Proof. - simple induction x. - simpl in |- *; trivial. - simple induction y. - simpl in |- *; trivial. - simpl in |- *; intros. - elim (index_lt i i0); simpl in |- *; intros. - - repeat rewrite ivl_aux_ok. - rewrite H. simpl in |- *. - rewrite ivl_aux_ok. - eauto. - - repeat rewrite ivl_aux_ok. - rewrite H0. - rewrite ivl_aux_ok. - eauto. -Qed. - -Remark ics_aux_ok : - forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s). -Proof. - simple induction s; simpl in |- *; intros. - trivial. - reflexivity. - reflexivity. -Qed. - -Remark interp_m_ok : - forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l). -Proof. - destruct l as [| i v]. - simpl in |- *; trivial. - reflexivity. -Qed. - -Lemma canonical_sum_merge_ok : - forall x y:canonical_sum, - interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y). - -simple induction x; simpl in |- *. -trivial. - -simple induction y; simpl in |- *; intros. -(* monom and nil *) -eauto. - -(* monom and monom *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. -repeat rewrite interp_m_ok. -rewrite (SR_distr_left T). -repeat rewrite <- (SR_plus_assoc T). -apply f_equal with (f := Aplus (Amult a (interp_vl v0))). -trivial. - -elim (varlist_lt v v0); simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. - -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; - eauto. - -(* monom and varlist *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. -repeat rewrite interp_m_ok. -rewrite (SR_distr_left T). -repeat rewrite <- (SR_plus_assoc T). -apply f_equal with (f := Aplus (Amult a (interp_vl v0))). -rewrite (SR_mult_one_left T). -trivial. - -elim (varlist_lt v v0); simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; - eauto. - -simple induction y; simpl in |- *; intros. -(* varlist and nil *) -trivial. - -(* varlist and monom *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. -repeat rewrite interp_m_ok. -rewrite (SR_distr_left T). -repeat rewrite <- (SR_plus_assoc T). -rewrite (SR_mult_one_left T). -apply f_equal with (f := Aplus (interp_vl v0)). -trivial. - -elim (varlist_lt v v0); simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; - eauto. - -(* varlist and varlist *) -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. -repeat rewrite interp_m_ok. -rewrite (SR_distr_left T). -repeat rewrite <- (SR_plus_assoc T). -rewrite (SR_mult_one_left T). -apply f_equal with (f := Aplus (interp_vl v0)). -trivial. - -elim (varlist_lt v v0); simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; - eauto. -Qed. - -Lemma monom_insert_ok : - forall (a:A) (l:varlist) (s:canonical_sum), - interp_cs (monom_insert a l s) = - Aplus (Amult a (interp_vl l)) (interp_cs s). -intros; generalize s; simple induction s0. - -simpl in |- *; rewrite interp_m_ok; trivial. - -simpl in |- *; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; - repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); - eauto. -elim (varlist_lt l v); simpl in |- *; - [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto - | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; - rewrite ics_aux_ok; eauto ]. - -simpl in |- *; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; - repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); - rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; - [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto - | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; - rewrite ics_aux_ok; eauto ]. -Qed. - -Lemma varlist_insert_ok : - forall (l:varlist) (s:canonical_sum), - interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s). -intros; generalize s; simple induction s0. - -simpl in |- *; trivial. - -simpl in |- *; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; - repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); - rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; - [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto - | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; - rewrite ics_aux_ok; eauto ]. - -simpl in |- *; intros. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; - repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); - rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; - [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto - | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; - rewrite ics_aux_ok; eauto ]. -Qed. - -Lemma canonical_sum_scalar_ok : - forall (a:A) (s:canonical_sum), - interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s). -simple induction s. -simpl in |- *; eauto. - -simpl in |- *; intros. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -reflexivity. - -simpl in |- *; intros. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -reflexivity. -Qed. - -Lemma canonical_sum_scalar2_ok : - forall (l:varlist) (s:canonical_sum), - interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s). -simple induction s. -simpl in |- *; trivial. - -simpl in |- *; intros. -rewrite monom_insert_ok. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -repeat rewrite <- (SR_plus_assoc T). -rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). -reflexivity. - -simpl in |- *; intros. -rewrite varlist_insert_ok. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -repeat rewrite <- (SR_plus_assoc T). -reflexivity. -Qed. - -Lemma canonical_sum_scalar3_ok : - forall (c:A) (l:varlist) (s:canonical_sum), - interp_cs (canonical_sum_scalar3 c l s) = - Amult c (Amult (interp_vl l) (interp_cs s)). -simple induction s. -simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity. - -simpl in |- *; intros. -rewrite monom_insert_ok. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -repeat rewrite <- (SR_plus_assoc T). -rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). -reflexivity. - -simpl in |- *; intros. -rewrite monom_insert_ok. -repeat rewrite ics_aux_ok. -repeat rewrite interp_m_ok. -rewrite H. -rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). -repeat rewrite <- (SR_mult_assoc T). -repeat rewrite <- (SR_plus_assoc T). -rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). -reflexivity. -Qed. - -Lemma canonical_sum_prod_ok : - forall x y:canonical_sum, - interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y). -simple induction x; simpl in |- *; intros. -trivial. - -rewrite canonical_sum_merge_ok. -rewrite canonical_sum_scalar3_ok. -rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite H. -rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)). -symmetry in |- *. -eauto. - -rewrite canonical_sum_merge_ok. -rewrite canonical_sum_scalar2_ok. -rewrite ics_aux_ok. -rewrite H. -trivial. -Qed. - -Theorem spolynomial_normalize_ok : - forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p. -simple induction p; simpl in |- *; intros. - -reflexivity. -reflexivity. - -rewrite canonical_sum_merge_ok. -rewrite H; rewrite H0. -reflexivity. - -rewrite canonical_sum_prod_ok. -rewrite H; rewrite H0. -reflexivity. -Qed. - -Lemma canonical_sum_simplify_ok : - forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s. -simple induction s. - -reflexivity. - -(* cons_monom *) -simpl in |- *; intros. -generalize (SR_eq_prop T a Azero). -elim (Aeq a Azero). -intro Heq; rewrite (Heq I). -rewrite H. -rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite (SR_mult_zero_left T). -trivial. - -intros; simpl in |- *. -generalize (SR_eq_prop T a Aone). -elim (Aeq a Aone). -intro Heq; rewrite (Heq I). -simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite H. -rewrite (SR_mult_one_left T). -reflexivity. - -simpl in |- *. -repeat rewrite ics_aux_ok. -rewrite interp_m_ok. -rewrite H. -reflexivity. - -(* cons_varlist *) -simpl in |- *; intros. -repeat rewrite ics_aux_ok. -rewrite H. -reflexivity. - -Qed. - -Theorem spolynomial_simplify_ok : - forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p. -intro. -unfold spolynomial_simplify in |- *. -rewrite canonical_sum_simplify_ok. -apply spolynomial_normalize_ok. -Qed. - -(* End properties. *) -End semi_rings. - -Implicit Arguments Cons_varlist. -Implicit Arguments Cons_monom. -Implicit Arguments SPconst. -Implicit Arguments SPplus. -Implicit Arguments SPmult. - -Section rings. - -(* Here the coercion between Ring and Semi-Ring will be useful *) - -Set Implicit Arguments. - -Variable A : Type. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. -Variable vm : varmap A. -Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. - -Hint Resolve (Th_plus_comm T). -Hint Resolve (Th_plus_assoc T). -Hint Resolve (Th_plus_assoc2 T). -Hint Resolve (Th_mult_comm T). -Hint Resolve (Th_mult_assoc T). -Hint Resolve (Th_mult_assoc2 T). -Hint Resolve (Th_plus_zero_left T). -Hint Resolve (Th_plus_zero_left2 T). -Hint Resolve (Th_mult_one_left T). -Hint Resolve (Th_mult_one_left2 T). -Hint Resolve (Th_mult_zero_left T). -Hint Resolve (Th_mult_zero_left2 T). -Hint Resolve (Th_distr_left T). -Hint Resolve (Th_distr_left2 T). -(*Hint Resolve (Th_plus_reg_left T).*) -Hint Resolve (Th_plus_permute T). -Hint Resolve (Th_mult_permute T). -Hint Resolve (Th_distr_right T). -Hint Resolve (Th_distr_right2 T). -Hint Resolve (Th_mult_zero_right T). -Hint Resolve (Th_mult_zero_right2 T). -Hint Resolve (Th_plus_zero_right T). -Hint Resolve (Th_plus_zero_right2 T). -Hint Resolve (Th_mult_one_right T). -Hint Resolve (Th_mult_one_right2 T). -(*Hint Resolve (Th_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) -Hint Immediate T. - -(*** Definitions *) - -Inductive polynomial : Type := - | Pvar : index -> polynomial - | Pconst : A -> polynomial - | Pplus : polynomial -> polynomial -> polynomial - | Pmult : polynomial -> polynomial -> polynomial - | Popp : polynomial -> polynomial. - -Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A := - match x with - | Pplus l r => - canonical_sum_merge Aplus Aone (polynomial_normalize l) - (polynomial_normalize r) - | Pmult l r => - canonical_sum_prod Aplus Amult Aone (polynomial_normalize l) - (polynomial_normalize r) - | Pconst c => Cons_monom c Nil_var (Nil_monom A) - | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A) - | Popp p => - canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var - (polynomial_normalize p) - end. - -Definition polynomial_simplify (x:polynomial) := - canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x). - -Fixpoint spolynomial_of (x:polynomial) : spolynomial A := - match x with - | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r) - | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r) - | Pconst c => SPconst c - | Pvar i => SPvar A i - | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p) - end. - -(*** Interpretation *) - -Fixpoint interp_p (p:polynomial) : A := - match p with - | Pconst c => c - | Pvar i => varmap_find Azero i vm - | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2) - | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2) - | Popp p1 => Aopp (interp_p p1) - end. - -(*** Properties *) - -Unset Implicit Arguments. - -Lemma spolynomial_of_ok : - forall p:polynomial, - interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p). -simple induction p; reflexivity || (simpl in |- *; intros). -rewrite H; rewrite H0; reflexivity. -rewrite H; rewrite H0; reflexivity. -rewrite H. -rewrite (Th_opp_mult_left2 T). -rewrite (Th_mult_one_left T). -reflexivity. -Qed. - -Theorem polynomial_normalize_ok : - forall p:polynomial, - polynomial_normalize p = - spolynomial_normalize Aplus Amult Aone (spolynomial_of p). -simple induction p; reflexivity || (simpl in |- *; intros). -rewrite H; rewrite H0; reflexivity. -rewrite H; rewrite H0; reflexivity. -rewrite H; simpl in |- *. -elim - (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var - (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); - [ reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity ]. -Qed. - -Theorem polynomial_simplify_ok : - forall p:polynomial, - interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p. -intro. -unfold polynomial_simplify in |- *. -rewrite spolynomial_of_ok. -rewrite polynomial_normalize_ok. -rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T). -rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T). -reflexivity. -Qed. - -End rings. - -Infix "+" := Pplus : ring_scope. -Infix "*" := Pmult : ring_scope. -Notation "- x" := (Popp x) : ring_scope. -Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope. - -Delimit Scope ring_scope with ring. diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v deleted file mode 100644 index 7bf33b17..00000000 --- a/contrib/ring/Setoid_ring.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -Require Export Setoid_ring_theory. -Require Export Quote. -Require Export Setoid_ring_normalize.
\ No newline at end of file diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v deleted file mode 100644 index 8eb49a37..00000000 --- a/contrib/ring/Setoid_ring_normalize.v +++ /dev/null @@ -1,1165 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *) - -Require Import Setoid_ring_theory. -Require Import Quote. - -Set Implicit Arguments. -Unset Boxed Definitions. - -Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. -Proof. - simple induction n; simple induction m; simpl in |- *; - try reflexivity || contradiction. - intros; rewrite (H i0); trivial. - intros; rewrite (H i0); trivial. -Qed. - -Section setoid. - -Variable A : Type. -Variable Aequiv : A -> A -> Prop. -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. - -Variable S : Setoid_Theory A Aequiv. - -Add Setoid A Aequiv S as Asetoid. - -Variable plus_morph : - forall a a0:A, Aequiv a a0 -> - forall a1 a2:A, Aequiv a1 a2 -> - Aequiv (Aplus a a1) (Aplus a0 a2). -Variable mult_morph : - forall a a0:A, Aequiv a a0 -> - forall a1 a2:A, Aequiv a1 a2 -> - Aequiv (Amult a a1) (Amult a0 a2). -Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0). - -Add Morphism Aplus : Aplus_ext. -intros; apply plus_morph; assumption. -Qed. - -Add Morphism Amult : Amult_ext. -intros; apply mult_morph; assumption. -Qed. - -Add Morphism Aopp : Aopp_ext. -exact opp_morph. -Qed. - -Let equiv_refl := Seq_refl A Aequiv S. -Let equiv_sym := Seq_sym A Aequiv S. -Let equiv_trans := Seq_trans A Aequiv S. - -Hint Resolve equiv_refl equiv_trans. -Hint Immediate equiv_sym. - -Section semi_setoid_rings. - -(* Section definitions. *) - - -(******************************************) -(* Normal abtract Polynomials *) -(******************************************) -(* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z -- A monom is a constant, a varlist or the product of a constant by a varlist - variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) -- A normal polynomial it either a constant or a canonical sum or a constant - plus a canonical sum -*) - -(* varlist is isomorphic to (list var), but we built a special inductive - for efficiency *) -Inductive varlist : Type := - | Nil_var : varlist - | Cons_var : index -> varlist -> varlist. - -Inductive canonical_sum : Type := - | Nil_monom : canonical_sum - | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum - | Cons_varlist : varlist -> canonical_sum -> canonical_sum. - -(* Order on monoms *) - -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom - - The relation between two varlist is preserved by multiplication by a - constant. - - Examples : - 3 < x < y - x*y < x*y*y*z - 2*x*y < x*y*y*z - x*y < 54*x*y*y*z - 4*x*y < 59*x*y*y*z -*) - -Fixpoint varlist_eq (x y:varlist) {struct y} : bool := - match x, y with - | Nil_var, Nil_var => true - | Cons_var i xrest, Cons_var j yrest => - andb (index_eq i j) (varlist_eq xrest yrest) - | _, _ => false - end. - -Fixpoint varlist_lt (x y:varlist) {struct y} : bool := - match x, y with - | Nil_var, Cons_var _ _ => true - | Cons_var i xrest, Cons_var j yrest => - if index_lt i j - then true - else andb (index_eq i j) (varlist_lt xrest yrest) - | _, _ => false - end. - -(* merges two variables lists *) -Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := - match l1 with - | Cons_var v1 t1 => - (fix vm_aux (l2:varlist) : varlist := - match l2 with - | Cons_var v2 t2 => - if index_lt v1 v2 - then Cons_var v1 (varlist_merge t1 l2) - else Cons_var v2 (vm_aux t2) - | Nil_var => l1 - end) - | Nil_var => fun l2 => l2 - end. - -(* returns the sum of two canonical sums *) -Fixpoint canonical_sum_merge (s1:canonical_sum) : - canonical_sum -> canonical_sum := - match s1 with - | Cons_monom c1 l1 t1 => - (fix csm_aux (s2:canonical_sum) : canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 (canonical_sum_merge t1 s2) - else Cons_monom c2 l2 (csm_aux t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 (canonical_sum_merge t1 s2) - else Cons_varlist l2 (csm_aux t2) - | Nil_monom => s1 - end) - | Cons_varlist l1 t1 => - (fix csm_aux2 (s2:canonical_sum) : canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_varlist l1 (canonical_sum_merge t1 s2) - else Cons_monom c2 l2 (csm_aux2 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) - else - if varlist_lt l1 l2 - then Cons_varlist l1 (canonical_sum_merge t1 s2) - else Cons_varlist l2 (csm_aux2 t2) - | Nil_monom => s1 - end) - | Nil_monom => fun s2 => s2 - end. - -(* Insertion of a monom in a canonical sum *) -Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : - canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 c2) l1 t2 - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 s2 - else Cons_monom c2 l2 (monom_insert c1 l1 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus c1 Aone) l1 t2 - else - if varlist_lt l1 l2 - then Cons_monom c1 l1 s2 - else Cons_varlist l2 (monom_insert c1 l1 t2) - | Nil_monom => Cons_monom c1 l1 Nil_monom - end. - -Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : - canonical_sum := - match s2 with - | Cons_monom c2 l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone c2) l1 t2 - else - if varlist_lt l1 l2 - then Cons_varlist l1 s2 - else Cons_monom c2 l2 (varlist_insert l1 t2) - | Cons_varlist l2 t2 => - if varlist_eq l1 l2 - then Cons_monom (Aplus Aone Aone) l1 t2 - else - if varlist_lt l1 l2 - then Cons_varlist l1 s2 - else Cons_varlist l2 (varlist_insert l1 t2) - | Nil_monom => Cons_varlist l1 Nil_monom - end. - -(* Computes c0*s *) -Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : - canonical_sum := - match s with - | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) - | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) - | Nil_monom => Nil_monom - end. - -(* Computes l0*s *) -Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : - canonical_sum := - match s with - | Cons_monom c l t => - monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) - | Cons_varlist l t => - varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) - | Nil_monom => Nil_monom - end. - -(* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) - (s:canonical_sum) {struct s} : canonical_sum := - match s with - | Cons_monom c l t => - monom_insert (Amult c0 c) (varlist_merge l0 l) - (canonical_sum_scalar3 c0 l0 t) - | Cons_varlist l t => - monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) - | Nil_monom => Nil_monom - end. - -(* returns the product of two canonical sums *) -Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : - canonical_sum := - match s1 with - | Cons_monom c1 l1 t1 => - canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) - (canonical_sum_prod t1 s2) - | Cons_varlist l1 t1 => - canonical_sum_merge (canonical_sum_scalar2 l1 s2) - (canonical_sum_prod t1 s2) - | Nil_monom => Nil_monom - end. - -(* The type to represent concrete semi-setoid-ring polynomials *) - -Inductive setspolynomial : Type := - | SetSPvar : index -> setspolynomial - | SetSPconst : A -> setspolynomial - | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial - | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial. - -Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum := - match p with - | SetSPplus l r => - canonical_sum_merge (setspolynomial_normalize l) - (setspolynomial_normalize r) - | SetSPmult l r => - canonical_sum_prod (setspolynomial_normalize l) - (setspolynomial_normalize r) - | SetSPconst c => Cons_monom c Nil_var Nil_monom - | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom - end. - -Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := - match s with - | Cons_monom c l t => - if Aeq c Azero - then canonical_sum_simplify t - else - if Aeq c Aone - then Cons_varlist l (canonical_sum_simplify t) - else Cons_monom c l (canonical_sum_simplify t) - | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) - | Nil_monom => Nil_monom - end. - -Definition setspolynomial_simplify (x:setspolynomial) := - canonical_sum_simplify (setspolynomial_normalize x). - -Variable vm : varmap A. - -Definition interp_var (i:index) := varmap_find Azero i vm. - -Definition ivl_aux := - (fix ivl_aux (x:index) (t:varlist) {struct t} : A := - match t with - | Nil_var => interp_var x - | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') - end). - -Definition interp_vl (l:varlist) := - match l with - | Nil_var => Aone - | Cons_var x t => ivl_aux x t - end. - -Definition interp_m (c:A) (l:varlist) := - match l with - | Nil_var => c - | Cons_var x t => Amult c (ivl_aux x t) - end. - -Definition ics_aux := - (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := - match s with - | Nil_monom => a - | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) - | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) - end). - -Definition interp_setcs (s:canonical_sum) : A := - match s with - | Nil_monom => Azero - | Cons_varlist l t => ics_aux (interp_vl l) t - | Cons_monom c l t => ics_aux (interp_m c l) t - end. - -Fixpoint interp_setsp (p:setspolynomial) : A := - match p with - | SetSPconst c => c - | SetSPvar i => interp_var i - | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2) - | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2) - end. - -(* End interpretation. *) - -Unset Implicit Arguments. - -(* Section properties. *) - -Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq. - -Hint Resolve (SSR_plus_comm T). -Hint Resolve (SSR_plus_assoc T). -Hint Resolve (SSR_plus_assoc2 S T). -Hint Resolve (SSR_mult_comm T). -Hint Resolve (SSR_mult_assoc T). -Hint Resolve (SSR_mult_assoc2 S T). -Hint Resolve (SSR_plus_zero_left T). -Hint Resolve (SSR_plus_zero_left2 S T). -Hint Resolve (SSR_mult_one_left T). -Hint Resolve (SSR_mult_one_left2 S T). -Hint Resolve (SSR_mult_zero_left T). -Hint Resolve (SSR_mult_zero_left2 S T). -Hint Resolve (SSR_distr_left T). -Hint Resolve (SSR_distr_left2 S T). -Hint Resolve (SSR_plus_reg_left T). -Hint Resolve (SSR_plus_permute S plus_morph T). -Hint Resolve (SSR_mult_permute S mult_morph T). -Hint Resolve (SSR_distr_right S plus_morph T). -Hint Resolve (SSR_distr_right2 S plus_morph T). -Hint Resolve (SSR_mult_zero_right S T). -Hint Resolve (SSR_mult_zero_right2 S T). -Hint Resolve (SSR_plus_zero_right S T). -Hint Resolve (SSR_plus_zero_right2 S T). -Hint Resolve (SSR_mult_one_right S T). -Hint Resolve (SSR_mult_one_right2 S T). -Hint Resolve (SSR_plus_reg_right S T). -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) -Hint Immediate T. - -Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. -Proof. - simple induction x; simple induction y; contradiction || (try reflexivity). - simpl in |- *; intros. - generalize (andb_prop2 _ _ H1); intros; elim H2; intros. - rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. -Qed. - -Remark ivl_aux_ok : - forall (v:varlist) (i:index), - Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)). -Proof. - simple induction v; simpl in |- *; intros. - trivial. - rewrite (H i); trivial. -Qed. - -Lemma varlist_merge_ok : - forall x y:varlist, - Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)). -Proof. - simple induction x. - simpl in |- *; trivial. - simple induction y. - simpl in |- *; trivial. - simpl in |- *; intros. - elim (index_lt i i0); simpl in |- *; intros. - - rewrite (ivl_aux_ok v i). - rewrite (ivl_aux_ok v0 i0). - rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i). - rewrite (H (Cons_var i0 v0)). - simpl in |- *. - rewrite (ivl_aux_ok v0 i0). - eauto. - - rewrite (ivl_aux_ok v i). - rewrite (ivl_aux_ok v0 i0). - rewrite - (ivl_aux_ok - ((fix vm_aux (l2:varlist) : varlist := - match l2 with - | Nil_var => Cons_var i v - | Cons_var v2 t2 => - if index_lt i v2 - then Cons_var i (varlist_merge v l2) - else Cons_var v2 (vm_aux t2) - end) v0) i0). - rewrite H0. - rewrite (ivl_aux_ok v i). - eauto. -Qed. - -Remark ics_aux_ok : - forall (x:A) (s:canonical_sum), - Aequiv (ics_aux x s) (Aplus x (interp_setcs s)). -Proof. - simple induction s; simpl in |- *; intros; trivial. -Qed. - -Remark interp_m_ok : - forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)). -Proof. - destruct l as [| i v]; trivial. -Qed. - -Hint Resolve ivl_aux_ok. -Hint Resolve ics_aux_ok. -Hint Resolve interp_m_ok. - -(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *) - -Lemma canonical_sum_merge_ok : - forall x y:canonical_sum, - Aequiv (interp_setcs (canonical_sum_merge x y)) - (Aplus (interp_setcs x) (interp_setcs y)). -Proof. -simple induction x; simpl in |- *. -trivial. - -simple induction y; simpl in |- *; intros. -eauto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *. -rewrite (ics_aux_ok (interp_m a v0) c). -rewrite (ics_aux_ok (interp_m a0 v0) c0). -rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)). -rewrite (H c0). -rewrite (interp_m_ok (Aplus a a0) v0). -rewrite (interp_m_ok a v0). -rewrite (interp_m_ok a0 v0). -setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with - (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))) - (Aplus (interp_setcs c) (interp_setcs c0))) with - (Aplus (Amult a (interp_vl v0)) - (Aplus (Amult a0 (interp_vl v0)) - (Aplus (interp_setcs c) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) - (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with - (Aplus (Amult a (interp_vl v0)) - (Aplus (interp_setcs c) - (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))); - [ idtac | trivial ]. -auto. - -elim (varlist_lt v v0); simpl in |- *. -intro. -rewrite - (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0))) - . -rewrite (ics_aux_ok (interp_m a v) c). -rewrite (ics_aux_ok (interp_m a0 v0) c0). -rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *. -rewrite (ics_aux_ok (interp_m a0 v0) c0); auto. - -intro. -rewrite - (ics_aux_ok (interp_m a0 v0) - ((fix csm_aux (s2:canonical_sum) : canonical_sum := - match s2 with - | Nil_monom => Cons_monom a v c - | Cons_monom c2 l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_monom a v (canonical_sum_merge c s2) - else Cons_monom c2 l2 (csm_aux t2) - | Cons_varlist l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_monom a v (canonical_sum_merge c s2) - else Cons_varlist l2 (csm_aux t2) - end) c0)). -rewrite H0. -rewrite (ics_aux_ok (interp_m a v) c); - rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; - auto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0)); - rewrite (ics_aux_ok (interp_m a v0) c); - rewrite (ics_aux_ok (interp_vl v0) c0). -rewrite (H c0). -rewrite (interp_m_ok (Aplus a Aone) v0). -rewrite (interp_m_ok a v0). -setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with - (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))) - (Aplus (interp_setcs c) (interp_setcs c0))) with - (Aplus (Amult a (interp_vl v0)) - (Aplus (Amult Aone (interp_vl v0)) - (Aplus (interp_setcs c) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c)) - (Aplus (interp_vl v0) (interp_setcs c0))) with - (Aplus (Amult a (interp_vl v0)) - (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); - [ idtac | trivial ]. -auto. - -elim (varlist_lt v v0); simpl in |- *. -intro. -rewrite - (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0))) - ; rewrite (ics_aux_ok (interp_m a v) c); - rewrite (ics_aux_ok (interp_vl v0) c0). -rewrite (H (Cons_varlist v0 c0)); simpl in |- *. -rewrite (ics_aux_ok (interp_vl v0) c0). -auto. - -intro. -rewrite - (ics_aux_ok (interp_vl v0) - ((fix csm_aux (s2:canonical_sum) : canonical_sum := - match s2 with - | Nil_monom => Cons_monom a v c - | Cons_monom c2 l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_monom a v (canonical_sum_merge c s2) - else Cons_monom c2 l2 (csm_aux t2) - | Cons_varlist l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_monom a v (canonical_sum_merge c s2) - else Cons_varlist l2 (csm_aux t2) - end) c0)); rewrite H0. -rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0); - simpl in |- *. -auto. - -simple induction y; simpl in |- *; intros. -trivial. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0). -intros; rewrite (H1 I). -simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0)); - rewrite (ics_aux_ok (interp_vl v0) c); - rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0). -rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0). -setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with - (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))) - (Aplus (interp_setcs c) (interp_setcs c0))) with - (Aplus (Amult Aone (interp_vl v0)) - (Aplus (Amult a (interp_vl v0)) - (Aplus (interp_setcs c) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (interp_vl v0) (interp_setcs c)) - (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with - (Aplus (interp_vl v0) - (Aplus (interp_setcs c) - (Aplus (Amult a (interp_vl v0)) (interp_setcs c0)))); - [ idtac | trivial ]. -auto. - -elim (varlist_lt v v0); simpl in |- *; intros. -rewrite - (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0))) - ; rewrite (ics_aux_ok (interp_vl v) c); - rewrite (ics_aux_ok (interp_m a v0) c0). -rewrite (H (Cons_monom a v0 c0)); simpl in |- *. -rewrite (ics_aux_ok (interp_m a v0) c0); auto. - -rewrite - (ics_aux_ok (interp_m a v0) - ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := - match s2 with - | Nil_monom => Cons_varlist v c - | Cons_monom c2 l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_varlist v (canonical_sum_merge c s2) - else Cons_monom c2 l2 (csm_aux2 t2) - | Cons_varlist l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_varlist v (canonical_sum_merge c s2) - else Cons_varlist l2 (csm_aux2 t2) - end) c0)); rewrite H0. -rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0); - simpl in |- *; auto. - -generalize (varlist_eq_prop v v0). -elim (varlist_eq v v0); intros. -rewrite (H1 I); simpl in |- *. -rewrite - (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0)) - ; rewrite (ics_aux_ok (interp_vl v0) c); - rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0). -rewrite (interp_m_ok (Aplus Aone Aone) v0). -setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with - (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))) - (Aplus (interp_setcs c) (interp_setcs c0))) with - (Aplus (Amult Aone (interp_vl v0)) - (Aplus (Amult Aone (interp_vl v0)) - (Aplus (interp_setcs c) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace - (Aplus (Aplus (interp_vl v0) (interp_setcs c)) - (Aplus (interp_vl v0) (interp_setcs c0))) with - (Aplus (interp_vl v0) - (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0)))); -[ idtac | trivial ]. -setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto. - -elim (varlist_lt v v0); simpl in |- *. -rewrite - (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0))) - ; rewrite (ics_aux_ok (interp_vl v) c); - rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0)); - simpl in |- *. -rewrite (ics_aux_ok (interp_vl v0) c0); auto. - -rewrite - (ics_aux_ok (interp_vl v0) - ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := - match s2 with - | Nil_monom => Cons_varlist v c - | Cons_monom c2 l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_varlist v (canonical_sum_merge c s2) - else Cons_monom c2 l2 (csm_aux2 t2) - | Cons_varlist l2 t2 => - if varlist_eq v l2 - then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) - else - if varlist_lt v l2 - then Cons_varlist v (canonical_sum_merge c s2) - else Cons_varlist l2 (csm_aux2 t2) - end) c0)); rewrite H0. -rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); - simpl in |- *; auto. -Qed. - -Lemma monom_insert_ok : - forall (a:A) (l:varlist) (s:canonical_sum), - Aequiv (interp_setcs (monom_insert a l s)) - (Aplus (Amult a (interp_vl l)) (interp_setcs s)). -Proof. -simple induction s; intros. -simpl in |- *; rewrite (interp_m_ok a l); trivial. - -simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c); - rewrite (ics_aux_ok (interp_m a0 v) c). -rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v). -setoid_replace (Amult (Aplus a a0) (interp_vl v)) with - (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))); - [ idtac | trivial ]. -auto. - -elim (varlist_lt l v); simpl in |- *; intros. -rewrite (ics_aux_ok (interp_m a0 v) c). -rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l). -auto. - -rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c)); - rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H. -auto. - -simpl in |- *. -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c); - rewrite (ics_aux_ok (interp_vl v) c). -rewrite (interp_m_ok (Aplus a Aone) v). -setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with - (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))); - [ idtac | trivial ]. -setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); - [ idtac | trivial ]. -auto. - -elim (varlist_lt l v); simpl in |- *; intros; auto. -rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H. -rewrite (ics_aux_ok (interp_vl v) c); auto. -Qed. - -Lemma varlist_insert_ok : - forall (l:varlist) (s:canonical_sum), - Aequiv (interp_setcs (varlist_insert l s)) - (Aplus (interp_vl l) (interp_setcs s)). -Proof. -simple induction s; simpl in |- *; intros. -trivial. - -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c); - rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v). -setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with - (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))); - [ idtac | trivial ]. -setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. - -elim (varlist_lt l v); simpl in |- *; intros; auto. -rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c)); - rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok a v). -rewrite H; auto. - -generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. -rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c); - rewrite (ics_aux_ok (interp_vl v) c). -rewrite (interp_m_ok (Aplus Aone Aone) v). -setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with - (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))); - [ idtac | trivial ]. -setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. - -elim (varlist_lt l v); simpl in |- *; intros; auto. -rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)). -rewrite H. -rewrite (ics_aux_ok (interp_vl v) c); auto. -Qed. - -Lemma canonical_sum_scalar_ok : - forall (a:A) (s:canonical_sum), - Aequiv (interp_setcs (canonical_sum_scalar a s)) - (Amult a (interp_setcs s)). -Proof. -simple induction s; simpl in |- *; intros. -trivial. - -rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c)); - rewrite (ics_aux_ok (interp_m a0 v) c). -rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v). -rewrite H. -setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c))) - with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))); - [ idtac | trivial ]. -auto. - -rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c)); - rewrite (ics_aux_ok (interp_vl v) c); rewrite H. -rewrite (interp_m_ok a v). -auto. -Qed. - -Lemma canonical_sum_scalar2_ok : - forall (l:varlist) (s:canonical_sum), - Aequiv (interp_setcs (canonical_sum_scalar2 l s)) - (Amult (interp_vl l) (interp_setcs s)). -Proof. -simple induction s; simpl in |- *; intros; auto. -rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)). -rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok a v). -rewrite H. -rewrite (varlist_merge_ok l v). -setoid_replace - (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with - (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) - (Amult (interp_vl l) (interp_setcs c))); - [ idtac | trivial ]. -auto. - -rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)). -rewrite (ics_aux_ok (interp_vl v) c). -rewrite H. -rewrite (varlist_merge_ok l v). -auto. -Qed. - -Lemma canonical_sum_scalar3_ok : - forall (c:A) (l:varlist) (s:canonical_sum), - Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) - (Amult c (Amult (interp_vl l) (interp_setcs s))). -Proof. -simple induction s; simpl in |- *; intros. -rewrite (SSR_mult_zero_right S T (interp_vl l)). -auto. - -rewrite - (monom_insert_ok (Amult c a) (varlist_merge l v) - (canonical_sum_scalar3 c l c0)). -rewrite (ics_aux_ok (interp_m a v) c0). -rewrite (interp_m_ok a v). -rewrite H. -rewrite (varlist_merge_ok l v). -setoid_replace - (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with - (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) - (Amult (interp_vl l) (interp_setcs c0))); - [ idtac | trivial ]. -setoid_replace - (Amult c - (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) - (Amult (interp_vl l) (interp_setcs c0)))) with - (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v)))) - (Amult c (Amult (interp_vl l) (interp_setcs c0)))); - [ idtac | trivial ]. -setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with - (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))); - [ idtac | trivial ]. -auto. - -rewrite - (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0)) - . -rewrite (ics_aux_ok (interp_vl v) c0). -rewrite H. -rewrite (varlist_merge_ok l v). -setoid_replace - (Aplus (Amult c (Amult (interp_vl l) (interp_vl v))) - (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with - (Amult c - (Aplus (Amult (interp_vl l) (interp_vl v)) - (Amult (interp_vl l) (interp_setcs c0)))); - [ idtac | trivial ]. -auto. -Qed. - -Lemma canonical_sum_prod_ok : - forall x y:canonical_sum, - Aequiv (interp_setcs (canonical_sum_prod x y)) - (Amult (interp_setcs x) (interp_setcs y)). -Proof. -simple induction x; simpl in |- *; intros. -trivial. - -rewrite - (canonical_sum_merge_ok (canonical_sum_scalar3 a v y) - (canonical_sum_prod c y)). -rewrite (canonical_sum_scalar3_ok a v y). -rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok a v). -rewrite (H y). -setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with - (Amult (Amult a (interp_vl v)) (interp_setcs y)); - [ idtac | trivial ]. -setoid_replace - (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y)) - with - (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y)) - (Amult (interp_setcs c) (interp_setcs y))); - [ idtac | trivial ]. -trivial. - -rewrite - (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y)) - . -rewrite (canonical_sum_scalar2_ok v y). -rewrite (ics_aux_ok (interp_vl v) c). -rewrite (H y). -trivial. -Qed. - -Theorem setspolynomial_normalize_ok : - forall p:setspolynomial, - Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p). -Proof. -simple induction p; simpl in |- *; intros; trivial. -rewrite - (canonical_sum_merge_ok (setspolynomial_normalize s) - (setspolynomial_normalize s0)). -rewrite H; rewrite H0; trivial. - -rewrite - (canonical_sum_prod_ok (setspolynomial_normalize s) - (setspolynomial_normalize s0)). -rewrite H; rewrite H0; trivial. -Qed. - -Lemma canonical_sum_simplify_ok : - forall s:canonical_sum, - Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s). -Proof. -simple induction s; simpl in |- *; intros. -trivial. - -generalize (SSR_eq_prop T a Azero). -elim (Aeq a Azero). -simpl in |- *. -intros. -rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok a v). -rewrite (H0 I). -setoid_replace (Amult Azero (interp_vl v)) with Azero; - [ idtac | trivial ]. -rewrite H. -trivial. - -intros; simpl in |- *. -generalize (SSR_eq_prop T a Aone). -elim (Aeq a Aone). -intros. -rewrite (ics_aux_ok (interp_m a v) c). -rewrite (interp_m_ok a v). -rewrite (H1 I). -simpl in |- *. -rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). -rewrite H. -auto. - -simpl in |- *. -intros. -rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)). -rewrite (ics_aux_ok (interp_m a v) c). -rewrite H; trivial. - -rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). -rewrite H. -auto. -Qed. - -Theorem setspolynomial_simplify_ok : - forall p:setspolynomial, - Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p). -Proof. -intro. -unfold setspolynomial_simplify in |- *. -rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). -exact (setspolynomial_normalize_ok p). -Qed. - -End semi_setoid_rings. - -Implicit Arguments Cons_varlist. -Implicit Arguments Cons_monom. -Implicit Arguments SetSPconst. -Implicit Arguments SetSPplus. -Implicit Arguments SetSPmult. - - - -Section setoid_rings. - -Set Implicit Arguments. - -Variable vm : varmap A. -Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq. - -Hint Resolve (STh_plus_comm T). -Hint Resolve (STh_plus_assoc T). -Hint Resolve (STh_plus_assoc2 S T). -Hint Resolve (STh_mult_comm T). -Hint Resolve (STh_mult_assoc T). -Hint Resolve (STh_mult_assoc2 S T). -Hint Resolve (STh_plus_zero_left T). -Hint Resolve (STh_plus_zero_left2 S T). -Hint Resolve (STh_mult_one_left T). -Hint Resolve (STh_mult_one_left2 S T). -Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T). -Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T). -Hint Resolve (STh_distr_left T). -Hint Resolve (STh_distr_left2 S T). -Hint Resolve (STh_plus_reg_left S plus_morph T). -Hint Resolve (STh_plus_permute S plus_morph T). -Hint Resolve (STh_mult_permute S mult_morph T). -Hint Resolve (STh_distr_right S plus_morph T). -Hint Resolve (STh_distr_right2 S plus_morph T). -Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T). -Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T). -Hint Resolve (STh_plus_zero_right S T). -Hint Resolve (STh_plus_zero_right2 S T). -Hint Resolve (STh_mult_one_right S T). -Hint Resolve (STh_mult_one_right2 S T). -Hint Resolve (STh_plus_reg_right S plus_morph T). -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) -Hint Immediate T. - - -(*** Definitions *) - -Inductive setpolynomial : Type := - | SetPvar : index -> setpolynomial - | SetPconst : A -> setpolynomial - | SetPplus : setpolynomial -> setpolynomial -> setpolynomial - | SetPmult : setpolynomial -> setpolynomial -> setpolynomial - | SetPopp : setpolynomial -> setpolynomial. - -Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum := - match x with - | SetPplus l r => - canonical_sum_merge (setpolynomial_normalize l) - (setpolynomial_normalize r) - | SetPmult l r => - canonical_sum_prod (setpolynomial_normalize l) - (setpolynomial_normalize r) - | SetPconst c => Cons_monom c Nil_var Nil_monom - | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom - | SetPopp p => - canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p) - end. - -Definition setpolynomial_simplify (x:setpolynomial) := - canonical_sum_simplify (setpolynomial_normalize x). - -Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial := - match x with - | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r) - | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r) - | SetPconst c => SetSPconst c - | SetPvar i => SetSPvar i - | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p) - end. - -(*** Interpretation *) - -Fixpoint interp_setp (p:setpolynomial) : A := - match p with - | SetPconst c => c - | SetPvar i => varmap_find Azero i vm - | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2) - | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2) - | SetPopp p1 => Aopp (interp_setp p1) - end. - -(*** Properties *) - -Unset Implicit Arguments. - -Lemma setspolynomial_of_ok : - forall p:setpolynomial, - Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)). -simple induction p; trivial; simpl in |- *; intros. -rewrite H; rewrite H0; trivial. -rewrite H; rewrite H0; trivial. -rewrite H. -rewrite - (STh_opp_mult_left2 S plus_morph mult_morph T Aone - (interp_setsp vm (setspolynomial_of s))). -rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))). -trivial. -Qed. - -Theorem setpolynomial_normalize_ok : - forall p:setpolynomial, - setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p). -simple induction p; trivial; simpl in |- *; intros. -rewrite H; rewrite H0; reflexivity. -rewrite H; rewrite H0; reflexivity. -rewrite H; simpl in |- *. -elim - (canonical_sum_scalar3 (Aopp Aone) Nil_var - (setspolynomial_normalize (setspolynomial_of s))); - [ reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity ]. -Qed. - -Theorem setpolynomial_simplify_ok : - forall p:setpolynomial, - Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p). -intro. -unfold setpolynomial_simplify in |- *. -rewrite (setspolynomial_of_ok p). -rewrite setpolynomial_normalize_ok. -rewrite - (canonical_sum_simplify_ok vm - (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq - plus_morph mult_morph T) - (setspolynomial_normalize (setspolynomial_of p))) - . -rewrite - (setspolynomial_normalize_ok vm - (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq - plus_morph mult_morph T) (setspolynomial_of p)) - . -trivial. -Qed. - -End setoid_rings. - -End setoid. diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v deleted file mode 100644 index 88abd7de..00000000 --- a/contrib/ring/Setoid_ring_theory.v +++ /dev/null @@ -1,427 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *) - -Require Export Bool. -Require Export Setoid. - -Set Implicit Arguments. - -Section Setoid_rings. - -Variable A : Type. -Variable Aequiv : A -> A -> Prop. - -Infix Local "==" := Aequiv (at level 70, no associativity). - -Variable S : Setoid_Theory A Aequiv. - -Add Setoid A Aequiv S as Asetoid. - -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. - -Infix "+" := Aplus (at level 50, left associativity). -Infix "*" := Amult (at level 40, left associativity). -Notation "0" := Azero. -Notation "1" := Aone. -Notation "- x" := (Aopp x). - -Variable plus_morph : - forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2. -Variable mult_morph : - forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2. -Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0. - -Add Morphism Aplus : Aplus_ext. -intros; apply plus_morph; assumption. -Qed. - -Add Morphism Amult : Amult_ext. -intros; apply mult_morph; assumption. -Qed. - -Add Morphism Aopp : Aopp_ext. -exact opp_morph. -Qed. - -Section Theory_of_semi_setoid_rings. - -Record Semi_Setoid_Ring_Theory : Prop := - {SSR_plus_comm : forall n m:A, n + m == m + n; - SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; - SSR_mult_comm : forall n m:A, n * m == m * n; - SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; - SSR_plus_zero_left : forall n:A, 0 + n == n; - SSR_mult_one_left : forall n:A, 1 * n == n; - SSR_mult_zero_left : forall n:A, 0 * n == 0; - SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; - SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p; - SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. - -Variable T : Semi_Setoid_Ring_Theory. - -Let plus_comm := SSR_plus_comm T. -Let plus_assoc := SSR_plus_assoc T. -Let mult_comm := SSR_mult_comm T. -Let mult_assoc := SSR_mult_assoc T. -Let plus_zero_left := SSR_plus_zero_left T. -Let mult_one_left := SSR_mult_one_left T. -Let mult_zero_left := SSR_mult_zero_left T. -Let distr_left := SSR_distr_left T. -Let plus_reg_left := SSR_plus_reg_left T. -Let equiv_refl := Seq_refl A Aequiv S. -Let equiv_sym := Seq_sym A Aequiv S. -Let equiv_trans := Seq_trans A Aequiv S. - -Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left - mult_one_left mult_zero_left distr_left plus_reg_left - equiv_refl (*equiv_sym*). -Hint Immediate equiv_sym. - -(* Lemmas whose form is x=y are also provided in form y=x because - Auto does not symmetry *) -Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). -auto. Qed. - -Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). -auto. Qed. - -Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n. -auto. Qed. - -Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n. -auto. Qed. - -Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n. -auto. Qed. - -Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. -auto. Qed. - -Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). -intros. -rewrite (plus_assoc n m p). -rewrite (plus_comm n m). -rewrite <- (plus_assoc m n p). -trivial. -Qed. - -Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). -intros. -rewrite (mult_assoc n m p). -rewrite (mult_comm n m). -rewrite <- (mult_assoc m n p). -trivial. -Qed. - -Hint Resolve SSR_plus_permute SSR_mult_permute. - -Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. -intros. -rewrite (mult_comm n (m + p)). -rewrite (mult_comm n m). -rewrite (mult_comm n p). -auto. -Qed. - -Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). -intros. -apply equiv_sym. -apply SSR_distr_right. -Qed. - -Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0. -intro; rewrite (mult_comm n 0); auto. -Qed. - -Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0. -intro; rewrite (mult_comm n 0); auto. -Qed. - -Lemma SSR_plus_zero_right : forall n:A, n + 0 == n. -intro; rewrite (plus_comm n 0); auto. -Qed. - -Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0. -intro; rewrite (plus_comm n 0); auto. -Qed. - -Lemma SSR_mult_one_right : forall n:A, n * 1 == n. -intro; rewrite (mult_comm n 1); auto. -Qed. - -Lemma SSR_mult_one_right2 : forall n:A, n == n * 1. -intro; rewrite (mult_comm n 1); auto. -Qed. - -Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. -intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n). -intro; apply plus_reg_left with n; trivial. -Qed. - -End Theory_of_semi_setoid_rings. - -Section Theory_of_setoid_rings. - -Record Setoid_Ring_Theory : Prop := - {STh_plus_comm : forall n m:A, n + m == m + n; - STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; - STh_mult_comm : forall n m:A, n * m == m * n; - STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; - STh_plus_zero_left : forall n:A, 0 + n == n; - STh_mult_one_left : forall n:A, 1 * n == n; - STh_opp_def : forall n:A, n + - n == 0; - STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; - STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. - -Variable T : Setoid_Ring_Theory. - -Let plus_comm := STh_plus_comm T. -Let plus_assoc := STh_plus_assoc T. -Let mult_comm := STh_mult_comm T. -Let mult_assoc := STh_mult_assoc T. -Let plus_zero_left := STh_plus_zero_left T. -Let mult_one_left := STh_mult_one_left T. -Let opp_def := STh_opp_def T. -Let distr_left := STh_distr_left T. -Let equiv_refl := Seq_refl A Aequiv S. -Let equiv_sym := Seq_sym A Aequiv S. -Let equiv_trans := Seq_trans A Aequiv S. - -Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left - mult_one_left opp_def distr_left equiv_refl equiv_sym. - -(* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) - -Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). -auto. Qed. - -Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). -auto. Qed. - -Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n. -auto. Qed. - -Lemma STh_mult_one_left2 : forall n:A, n == 1 * n. -auto. Qed. - -Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. -auto. Qed. - -Lemma STh_opp_def2 : forall n:A, 0 == n + - n. -auto. Qed. - -Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). -intros. -rewrite (plus_assoc n m p). -rewrite (plus_comm n m). -rewrite <- (plus_assoc m n p). -trivial. -Qed. - -Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). -intros. -rewrite (mult_assoc n m p). -rewrite (mult_comm n m). -rewrite <- (mult_assoc m n p). -trivial. -Qed. - -Hint Resolve STh_plus_permute STh_mult_permute. - -Lemma Saux1 : forall a:A, a + a == a -> a == 0. -intros. -rewrite <- (plus_zero_left a). -rewrite (plus_comm 0 a). -setoid_replace (a + 0) with (a + (a + - a)) by auto. -rewrite (plus_assoc a a (- a)). -rewrite H. -apply opp_def. -Qed. - -Lemma STh_mult_zero_left : forall n:A, 0 * n == 0. -intros. -apply Saux1. -rewrite <- (distr_left 0 0 n). -rewrite (plus_zero_left 0). -trivial. -Qed. -Hint Resolve STh_mult_zero_left. - -Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n. -auto. -Qed. - -Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z. -intros. -rewrite <- (plus_zero_left y). -rewrite <- H0. -rewrite <- (plus_assoc x z y). -rewrite (plus_comm z y). -rewrite (plus_assoc x y z). -rewrite H. -auto. -Qed. - -Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y. -intros. -apply Saux2 with (x * y); auto. -rewrite <- (distr_left x (- x) y). -rewrite (opp_def x). -auto. -Qed. -Hint Resolve STh_opp_mult_left. - -Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y). -auto. -Qed. - -Lemma STh_mult_zero_right : forall n:A, n * 0 == 0. -intro; rewrite (mult_comm n 0); auto. -Qed. - -Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0. -intro; rewrite (mult_comm n 0); auto. -Qed. - -Lemma STh_plus_zero_right : forall n:A, n + 0 == n. -intro; rewrite (plus_comm n 0); auto. -Qed. - -Lemma STh_plus_zero_right2 : forall n:A, n == n + 0. -intro; rewrite (plus_comm n 0); auto. -Qed. - -Lemma STh_mult_one_right : forall n:A, n * 1 == n. -intro; rewrite (mult_comm n 1); auto. -Qed. - -Lemma STh_mult_one_right2 : forall n:A, n == n * 1. -intro; rewrite (mult_comm n 1); auto. -Qed. - -Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y. -intros. -rewrite (mult_comm x y). -rewrite (mult_comm x (- y)). -auto. -Qed. - -Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y). -intros. -rewrite (mult_comm x y). -rewrite (mult_comm x (- y)). -auto. -Qed. - -Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y). -intros. -apply Saux2 with (x + y); auto. -rewrite (STh_plus_permute (x + y) (- x) (- y)). -rewrite <- (plus_assoc x y (- y)). -rewrite (opp_def y); rewrite (STh_plus_zero_right x). -rewrite (STh_opp_def2 x); trivial. -Qed. - -Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p). -auto. -Qed. - -Lemma STh_opp_opp : forall n:A, - - n == n. -intro. -apply Saux2 with (- n); auto. -rewrite (plus_comm (- n) n); auto. -Qed. -Hint Resolve STh_opp_opp. - -Lemma STh_opp_opp2 : forall n:A, n == - - n. -auto. -Qed. - -Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y. -intros. -rewrite (STh_opp_mult_left2 x (- y)). -rewrite (STh_opp_mult_right2 x y). -trivial. -Qed. - -Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y. -intros. -apply equiv_sym. -apply STh_mult_opp_opp. -Qed. - -Lemma STh_opp_zero : - 0 == 0. -rewrite <- (plus_zero_left (- 0)). -trivial. -Qed. - -Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p. -intros. -rewrite <- (plus_zero_left m). -rewrite <- (plus_zero_left p). -rewrite <- (opp_def n). -rewrite (plus_comm n (- n)). -rewrite <- (plus_assoc (- n) n m). -rewrite <- (plus_assoc (- n) n p). -auto. -Qed. - -Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. -intros. -apply STh_plus_reg_left with n. -rewrite (plus_comm n m); rewrite (plus_comm n p); assumption. -Qed. - -Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. -intros. -rewrite (mult_comm n (m + p)). -rewrite (mult_comm n m). -rewrite (mult_comm n p). -trivial. -Qed. - -Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). -intros. -apply equiv_sym. -apply STh_distr_right. -Qed. - -End Theory_of_setoid_rings. - -Hint Resolve STh_mult_zero_left STh_plus_reg_left: core. - -Unset Implicit Arguments. - -Definition Semi_Setoid_Ring_Theory_of : - Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory. -intros until 1; case H. -split; intros; simpl in |- *; eauto. -Defined. - -Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >-> - Semi_Setoid_Ring_Theory. - - - -Section product_ring. - -End product_ring. - -Section power_ring. - -End power_ring. - -End Setoid_rings. diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4 deleted file mode 100644 index d0058026..00000000 --- a/contrib/ring/g_quote.ml4 +++ /dev/null @@ -1,18 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_quote.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) - -open Quote - -TACTIC EXTEND quote - [ "quote" ident(f) ] -> [ quote f [] ] -| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] -END diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4 deleted file mode 100644 index 2f964988..00000000 --- a/contrib/ring/g_ring.ml4 +++ /dev/null @@ -1,136 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *) - -open Quote -open Ring -open Tacticals - -TACTIC EXTEND ring -| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ] -END - -(* The vernac commands "Add Ring" and co *) - -let cset_of_constrarg_list l = - List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty - -VERNAC COMMAND EXTEND AddRing - [ "Add" "Legacy" "Ring" - constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] - -> [ add_theory true false false - (constr_of a) - None - None - None - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - (Some (constr_of aopp)) - (constr_of aeq) - (constr_of t) - (cset_of_constrarg_list l) ] - -| [ "Add" "Legacy" "Semi" "Ring" - constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] - -> [ add_theory false false false - (constr_of a) - None - None - None - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - None - (constr_of aeq) - (constr_of t) - (cset_of_constrarg_list l) ] - -| [ "Add" "Legacy" "Abstract" "Ring" - constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aopp) constr(aeq) constr(t) ] - -> [ add_theory true true false - (constr_of a) - None - None - None - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - (Some (constr_of aopp)) - (constr_of aeq) - (constr_of t) - ConstrSet.empty ] - -| [ "Add" "Legacy" "Abstract" "Semi" "Ring" - constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aeq) constr(t) ] - -> [ add_theory false true false - (constr_of a) - None - None - None - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - None - (constr_of aeq) - (constr_of t) - ConstrSet.empty ] - -| [ "Add" "Legacy" "Setoid" "Ring" - constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) - constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) - constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] - -> [ add_theory true false true - (constr_of a) - (Some (constr_of aequiv)) - (Some (constr_of asetth)) - (Some { - plusm = (constr_of pm); - multm = (constr_of mm); - oppm = Some (constr_of om) }) - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - (Some (constr_of aopp)) - (constr_of aeq) - (constr_of t) - (cset_of_constrarg_list l) ] - -| [ "Add" "Legacy" "Semi" "Setoid" "Ring" - constr(a) constr(aequiv) constr(asetth) constr(aplus) - constr(amult) constr(aone) constr(azero) constr(aeq) - constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] - -> [ add_theory false false true - (constr_of a) - (Some (constr_of aequiv)) - (Some (constr_of asetth)) - (Some { - plusm = (constr_of pm); - multm = (constr_of mm); - oppm = None }) - (constr_of aplus) - (constr_of amult) - (constr_of aone) - (constr_of azero) - None - (constr_of aeq) - (constr_of t) - (cset_of_constrarg_list l) ] -END diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml deleted file mode 100644 index 7cd22a36..00000000 --- a/contrib/ring/quote.ml +++ /dev/null @@ -1,491 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *) - -(* The `Quote' tactic *) - -(* The basic idea is to automatize the inversion of interpetation functions - in 2-level approach - - Examples are given in \texttt{theories/DEMOS/DemoQuote.v} - - Suppose you have a langage \texttt{L} of 'abstract terms' - and a type \texttt{A} of 'concrete terms' - and a function \texttt{f : L -> (varmap A L) -> A}. - - Then, the tactic \texttt{Quote f} will replace an - expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} - such that \texttt{e} and \texttt{(f vm t)} are convertible. - - The problem is then inverting the function f. - - The tactic works when: - - \begin{itemize} - \item L is a simple inductive datatype. The constructors of L may - have one of the three following forms: - - \begin{enumerate} - \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| - \item variable leaf like: \verb|Cvar : index -> L| - \item constant leaf like \verb|Cconst : A -> L| - \end{enumerate} - - The definition of \texttt{L} must contain at most one variable - leaf and at most one constant leaf. - - When there are both a variable leaf and a constant leaf, there is - an ambiguity on inversion. The term t can be either the - interpretation of \texttt{(Cconst t)} or the interpretation of - (\texttt{Cvar}~$i$) in a variables map containing the binding $i - \rightarrow$~\texttt{t}. How to discriminate between these - choices ? - - To solve the dilemma, one gives to \texttt{Quote} a list of - \emph{constant constructors}: a term will be considered as a - constant if it is either a constant constructor of the - application of a constant constructor to constants. For example - the list \verb+[S, O]+ defines the closed natural - numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is - not. - - The definition of constants vary for each application of the - tactic, so it can even be different for two applications of - \texttt{Quote} with the same function. - - \item \texttt{f} is a quite simple fixpoint on - \texttt{L}. In particular, \texttt{f} must verify: - -\begin{verbatim} - (f (Cvar i)) = (varmap_find vm default_value i) -\end{verbatim} -\begin{verbatim} - (f (Cconst c)) = c -\end{verbatim} - - where \texttt{index} and \texttt{varmap\_find} are those defined - the \texttt{Quote} module. \emph{The tactic won't work with - user's own variables map !!} It is mandatory to use the - variables map defined in module \texttt{Quote}. - - \end{itemize} - - The method to proceed is then clear: - - \begin{itemize} - \item Start with an empty hashtable of "registed leafs" - that map constr to integers and a "variable counter" equal to 0. - \item Try to match the term with every right hand side of the - definition of f. - - If there is one match, returns the correponding left hand - side and call yourself recursively to get the arguments of this - left hand side. - - If there is no match, we are at a leaf. That is the - interpretation of either a variable or a constant. - - If it is a constant, return \texttt{Cconst} applied to that - constant. - - If not, it is a variable. Look in the hashtable - if this leaf has been already encountered. If not, increment - the variables counter and add an entry to the hashtable; then - return \texttt{(Cvar !variables\_counter)} - \end{itemize} -*) - - -(*i*) -open Pp -open Util -open Names -open Term -open Pattern -open Matching -open Tacmach -open Tactics -open Proof_trees -open Tacexpr -(*i*) - -(*s First, we need to access some Coq constants - We do that lazily, because this code can be linked before - the constants are loaded in the environment *) - -let constant dir s = Coqlib.gen_constant "Quote" ("ring"::dir) s - -let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") -let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") -let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") -let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") -let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") -let coq_End_idx = lazy (constant ["Quote"] "End_idx") - -(*s Then comes the stuff to decompose the body of interpetation function - and pre-compute the inversion data. - -For a function like: - -\begin{verbatim} - Fixpoint interp[vm:(varmap Prop); f:form] := - Cases f of - | (f_and f1 f1 f2) => (interp f1)/\(interp f2) - | (f_or f1 f1 f2) => (interp f1)\/(interp f2) - | (f_var i) => (varmap_find Prop default_v i vm) - | (f_const c) => c -\end{verbatim} - -With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the -corresponding scheme will be: - -\begin{verbatim} - {normal_lhs_rhs = - [ "(f_and ?1 ?2)", "?1 /\ ?2"; - "(f_or ?1 ?2)", " ?1 \/ ?2";]; - return_type = "Prop"; - constants = Some [C1,...Cn]; - variable_lhs = Some "(f_var ?1)"; - constant_lhs = Some "(f_const ?1)" - } -\end{verbatim} - -If there is no constructor for variables in the type \texttt{form}, -then [variable_lhs] is [None]. Idem for constants and -[constant_lhs]. Both cannot be equal to [None]. - -The metas in the RHS must correspond to those in the LHS (one cannot -exchange ?1 and ?2 in the example above) - -*) - -module ConstrSet = Set.Make( - struct - type t = constr - let compare = (Pervasives.compare : t->t->int) - end) - -type inversion_scheme = { - normal_lhs_rhs : (constr * constr_pattern) list; - variable_lhs : constr option; - return_type : constr; - constants : ConstrSet.t; - constant_lhs : constr option } - -(*s [compute_ivs gl f cs] computes the inversion scheme associated to - [f:constr] with constants list [cs:constr list] in the context of - goal [gl]. This function uses the auxiliary functions - [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) - -let i_can't_do_that () = error "Quote: not a simple fixpoint" - -let decomp_term c = kind_of_term (strip_outer_cast c) - -(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... - ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive - type [typ] *) - -let coerce_meta_out id = - let s = string_of_id id in - int_of_string (String.sub s 1 (String.length s - 1)) -let coerce_meta_in n = - id_of_string ("M" ^ string_of_int n) - -let compute_lhs typ i nargsi = - match kind_of_term typ with - | Ind(sp,0) -> - let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkConstruct ((sp,0),i+1), argsi) - | _ -> i_can't_do_that () - -(*s This function builds the pattern from the RHS. Recursive calls are - replaced by meta-variables ?i corresponding to those in the LHS *) - -let compute_rhs bodyi index_of_f = - let rec aux c = - match kind_of_term c with - | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> - let i = destRel (array_last args) in - PMeta (Some (coerce_meta_in i)) - | App (f,args) -> - PApp (pattern_of_constr f, Array.map aux args) - | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr c - in - aux bodyi - -(*s Now the function [compute_ivs] itself *) - -let compute_ivs gl f cs = - let cst = try destConst f with _ -> i_can't_do_that () in - let body = Environ.constant_value (Global.env()) cst in - match decomp_term body with - | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> - let (args3, body3) = decompose_lam body2 in - let nargs3 = List.length args3 in - begin match decomp_term body3 with - | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) - let n_lhs_rhs = ref [] - and v_lhs = ref (None : constr option) - and c_lhs = ref (None : constr option) in - Array.iteri - (fun i ci -> - let argsi, bodyi = decompose_lam ci in - let nargsi = List.length argsi in - (* REL (narg3 + nargsi + 1) is f *) - (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) - (* REL 1 to REL nargsi are argsi (reverse order) *) - (* First we test if the RHS is the RHS for constants *) - if bodyi = mkRel 1 then - c_lhs := Some (compute_lhs (snd (List.hd args3)) - i nargsi) - (* Then we test if the RHS is the RHS for variables *) - else begin match decompose_app bodyi with - | vmf, [_; _; a3; a4 ] - when isRel a3 & isRel a4 & - pf_conv_x gl vmf - (Lazy.force coq_varmap_find)-> - v_lhs := Some (compute_lhs - (snd (List.hd args3)) - i nargsi) - (* Third case: this is a normal LHS-RHS *) - | _ -> - n_lhs_rhs := - (compute_lhs (snd (List.hd args3)) i nargsi, - compute_rhs bodyi (nargs3 + nargsi + 1)) - :: !n_lhs_rhs - end) - lci; - - if !c_lhs = None & !v_lhs = None then i_can't_do_that (); - - (* The Cases predicate is a lambda; we assume no dependency *) - let p = match kind_of_term p with - | Lambda (_,_,p) -> Termops.pop p - | _ -> p - in - - { normal_lhs_rhs = List.rev !n_lhs_rhs; - variable_lhs = !v_lhs; - return_type = p; - constants = List.fold_right ConstrSet.add cs ConstrSet.empty; - constant_lhs = !c_lhs } - - | _ -> i_can't_do_that () - end - |_ -> i_can't_do_that () - -(* TODO for that function: -\begin{itemize} -\item handle the case where the return type is an argument of the - function -\item handle the case of simple mutual inductive (for example terms - and lists of terms) formulas with the corresponding mutual - recursvive interpretation functions. -\end{itemize} -*) - -(*s Stuff to build variables map, currently implemented as complete -binary search trees (see file \texttt{Quote.v}) *) - -(* First the function to distinghish between constants (closed terms) - and variables (open terms) *) - -let rec closed_under cset t = - (ConstrSet.mem t cset) or - (match (kind_of_term t) with - | Cast(c,_,_) -> closed_under cset c - | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l - | _ -> false) - -(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete - binary search tree containing the [ci], that is: - -\begin{verbatim} - c1 - / \ - c2 c3 - / \ - c4 c5 -\end{verbatim} - -The second argument is a constr (the common type of the [ci]) -*) - -let btree_of_array a ty = - let size_of_a = Array.length a in - let semi_size_of_a = size_of_a lsr 1 in - let node = Lazy.force coq_Node_vm - and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in - let rec aux n = - if n > size_of_a - then empty - else if n > semi_size_of_a - then mkApp (node, [| ty; a.(n-1); empty; empty |]) - else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) - in - aux 1 - -(*s [btree_of_array] and [path_of_int] verify the following invariant:\\ - {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] - = [a.(n)]\\ - [n] must be [> 0] *) - -let path_of_int n = - (* returns the list of digits of n in reverse order with - initial 1 removed *) - let rec digits_of_int n = - if n=1 then [] - else (n mod 2 = 1)::(digits_of_int (n lsr 1)) - in - List.fold_right - (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx - else Lazy.force coq_Left_idx), - [| c |])) - (List.rev (digits_of_int n)) - (Lazy.force coq_End_idx) - -(*s The tactic works with a list of subterms sharing the same - variables map. We need to sort terms in order to avoid than - strange things happen during replacement of terms by their - 'abstract' counterparties. *) - -(* [subterm t t'] tests if constr [t'] occurs in [t] *) -(* This function does not descend under binders (lambda and Cases) *) - -let rec subterm gl (t : constr) (t' : constr) = - (pf_conv_x gl t t') or - (match (kind_of_term t) with - | App (f,args) -> array_exists (fun t -> subterm gl t t') args - | Cast(t,_,_) -> (subterm gl t t') - | _ -> false) - -(*s We want to sort the list according to reverse subterm order. *) -(* Since it's a partial order the algoritm of Sort.list won't work !! *) - -let rec sort_subterm gl l = - let rec insert c = function - | [] -> [c] - | (h::t as l) when c = h -> l (* Avoid doing the same work twice *) - | h::t -> if subterm gl c h then c::h::t else h::(insert c t) - in - match l with - | [] -> [] - | h::t -> insert h (sort_subterm gl t) - -(*s Now we are able to do the inversion itself. - We destructurate the term and use an imperative hashtable - to store leafs that are already encountered. - The type of arguments is:\\ - [ivs : inversion_scheme]\\ - [lc: constr list]\\ - [gl: goal sigma]\\ *) - -let quote_terms ivs lc gl = - Coqlib.check_required_library ["Coq";"ring";"Quote"]; - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - let rec auxl l = - match l with - | (lhs, rhs)::tail -> - begin try - let s1 = matches rhs c in - let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 - in - Termops.subst_meta s2 lhs - with PatternMatchingFailure -> auxl tail - end - | [] -> - begin match ivs.variable_lhs with - | None -> - begin match ivs.constant_lhs with - | Some c_lhs -> Termops.subst_meta [1, c] c_lhs - | None -> anomaly "invalid inversion scheme for quote" - end - | Some var_lhs -> - begin match ivs.constant_lhs with - | Some c_lhs when closed_under ivs.constants c -> - Termops.subst_meta [1, c] c_lhs - | _ -> - begin - try Hashtbl.find varhash c - with Not_found -> - let newvar = - Termops.subst_meta [1, (path_of_int !counter)] - var_lhs in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - end - end - end - in - auxl ivs.normal_lhs_rhs - in - let lp = List.map aux lc in - (lp, (btree_of_array (Array.of_list (List.rev !varlist)) - ivs.return_type )) - -(*s actually we could "quote" a list of terms instead of the - conclusion of current goal. Ring for example needs that, but Ring doesn't - uses Quote yet. *) - -let quote f lid gl = - let f = pf_global gl f in - let cl = List.map (pf_global gl) lid in - let ivs = compute_ivs gl f cl in - let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with - | [p], vm -> (p,vm) - | _ -> assert false - in - match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl - -(*i - -Just testing ... - -#use "include.ml";; -open Quote;; - -let r = raw_constr_of_string;; - -let ivs = { - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") -};; - -let t1 = r "True/\(True /\ ~False)";; -let t2 = r "True/\~~False";; - -quote_term ivs () t1;; -quote_term ivs () t2;; - -let ivs2 = - normal_lhs_rhs = - [ r "(f_and ?1 ?2)", r "?1/\?2"; - r "(f_not ?1)", r "~?1" - r "True", r "f_true"]; - variable_lhs = Some (r "(f_atom ?1)"); - return_type = r "Prop"; - constants = ConstrSet.empty; - constant_lhs = (r "nat") - -i*) diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml deleted file mode 100644 index f2706307..00000000 --- a/contrib/ring/ring.ml +++ /dev/null @@ -1,926 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: ring.ml 11800 2009-01-18 18:34:15Z msozeau $ *) - -(* ML part of the Ring tactic *) - -open Pp -open Util -open Flags -open Term -open Names -open Libnames -open Nameops -open Reductionops -open Tacticals -open Tacexpr -open Tacmach -open Proof_trees -open Printer -open Equality -open Vernacinterp -open Vernacexpr -open Libobject -open Closure -open Tacred -open Tactics -open Pattern -open Hiddentac -open Nametab -open Quote -open Mod_subst - -let mt_evd = Evd.empty -let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c - -let ring_dir = ["Coq";"ring"] -let setoids_dir = ["Coq";"Setoids"] - -let ring_constant = Coqlib.gen_constant_in_modules "Ring" - [ring_dir@["LegacyRing_theory"]; - ring_dir@["Setoid_ring_theory"]; - ring_dir@["Ring_normalize"]; - ring_dir@["Ring_abstract"]; - setoids_dir@["Setoid"]; - ring_dir@["Setoid_ring_normalize"]] - -(* Ring theory *) -let coq_Ring_Theory = lazy (ring_constant "Ring_Theory") -let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory") - -(* Setoid ring theory *) -let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory") -let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory") - -(* Ring normalize *) -let coq_SPplus = lazy (ring_constant "SPplus") -let coq_SPmult = lazy (ring_constant "SPmult") -let coq_SPvar = lazy (ring_constant "SPvar") -let coq_SPconst = lazy (ring_constant "SPconst") -let coq_Pplus = lazy (ring_constant "Pplus") -let coq_Pmult = lazy (ring_constant "Pmult") -let coq_Pvar = lazy (ring_constant "Pvar") -let coq_Pconst = lazy (ring_constant "Pconst") -let coq_Popp = lazy (ring_constant "Popp") -let coq_interp_sp = lazy (ring_constant "interp_sp") -let coq_interp_p = lazy (ring_constant "interp_p") -let coq_interp_cs = lazy (ring_constant "interp_cs") -let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify") -let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify") -let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok") -let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok") - -(* Setoid theory *) -let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory") - -let coq_seq_refl = lazy(ring_constant "Seq_refl") -let coq_seq_sym = lazy(ring_constant "Seq_sym") -let coq_seq_trans = lazy(ring_constant "Seq_trans") - -(* Setoid Ring normalize *) -let coq_SetSPplus = lazy (ring_constant "SetSPplus") -let coq_SetSPmult = lazy (ring_constant "SetSPmult") -let coq_SetSPvar = lazy (ring_constant "SetSPvar") -let coq_SetSPconst = lazy (ring_constant "SetSPconst") -let coq_SetPplus = lazy (ring_constant "SetPplus") -let coq_SetPmult = lazy (ring_constant "SetPmult") -let coq_SetPvar = lazy (ring_constant "SetPvar") -let coq_SetPconst = lazy (ring_constant "SetPconst") -let coq_SetPopp = lazy (ring_constant "SetPopp") -let coq_interp_setsp = lazy (ring_constant "interp_setsp") -let coq_interp_setp = lazy (ring_constant "interp_setp") -let coq_interp_setcs = lazy (ring_constant "interp_setcs") -let coq_setspolynomial_simplify = - lazy (ring_constant "setspolynomial_simplify") -let coq_setpolynomial_simplify = - lazy (ring_constant "setpolynomial_simplify") -let coq_setspolynomial_simplify_ok = - lazy (ring_constant "setspolynomial_simplify_ok") -let coq_setpolynomial_simplify_ok = - lazy (ring_constant "setpolynomial_simplify_ok") - -(* Ring abstract *) -let coq_ASPplus = lazy (ring_constant "ASPplus") -let coq_ASPmult = lazy (ring_constant "ASPmult") -let coq_ASPvar = lazy (ring_constant "ASPvar") -let coq_ASP0 = lazy (ring_constant "ASP0") -let coq_ASP1 = lazy (ring_constant "ASP1") -let coq_APplus = lazy (ring_constant "APplus") -let coq_APmult = lazy (ring_constant "APmult") -let coq_APvar = lazy (ring_constant "APvar") -let coq_AP0 = lazy (ring_constant "AP0") -let coq_AP1 = lazy (ring_constant "AP1") -let coq_APopp = lazy (ring_constant "APopp") -let coq_interp_asp = lazy (ring_constant "interp_asp") -let coq_interp_ap = lazy (ring_constant "interp_ap") -let coq_interp_acs = lazy (ring_constant "interp_acs") -let coq_interp_sacs = lazy (ring_constant "interp_sacs") -let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize") -let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize") -let coq_aspolynomial_normalize_ok = - lazy (ring_constant "aspolynomial_normalize_ok") -let coq_apolynomial_normalize_ok = - lazy (ring_constant "apolynomial_normalize_ok") - -(* Logic --> to be found in Coqlib *) -open Coqlib - -let mkLApp(fc,v) = mkApp(Lazy.force fc, v) - -(*********** Useful types and functions ************) - -module OperSet = - Set.Make (struct - type t = global_reference - let compare = (Pervasives.compare : t->t->int) - end) - -type morph = - { plusm : constr; - multm : constr; - oppm : constr option; - } - -type theory = - { th_ring : bool; (* false for a semi-ring *) - th_abstract : bool; - th_setoid : bool; (* true for a setoid ring *) - th_equiv : constr option; - th_setoid_th : constr option; - th_morph : morph option; - th_a : constr; (* e.g. nat *) - th_plus : constr; - th_mult : constr; - th_one : constr; - th_zero : constr; - th_opp : constr option; (* None if semi-ring *) - th_eq : constr; - th_t : constr; (* e.g. NatTheory *) - th_closed : ConstrSet.t; (* e.g. [S; O] *) - (* Must be empty for an abstract ring *) - } - -(* Theories are stored in a table which is synchronised with the Reset - mechanism. *) - -module Cmap = Map.Make(struct type t = constr let compare = compare end) - -let theories_map = ref Cmap.empty - -let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map -let theories_map_find c = Cmap.find c !theories_map -let theories_map_mem c = Cmap.mem c !theories_map - -let _ = - Summary.declare_summary "tactic-ring-table" - { Summary.freeze_function = (fun () -> !theories_map); - Summary.unfreeze_function = (fun t -> theories_map := t); - Summary.init_function = (fun () -> theories_map := Cmap.empty); - Summary.survive_module = false; - Summary.survive_section = false } - -(* declare a new type of object in the environment, "tactic-ring-theory" - The functions theory_to_obj and obj_to_theory do the conversions - between theories and environement objects. *) - - -let subst_morph subst morph = - let plusm' = subst_mps subst morph.plusm in - let multm' = subst_mps subst morph.multm in - let oppm' = Option.smartmap (subst_mps subst) morph.oppm in - if plusm' == morph.plusm - && multm' == morph.multm - && oppm' == morph.oppm then - morph - else - { plusm = plusm' ; - multm = multm' ; - oppm = oppm' ; - } - -let subst_set subst cset = - let same = ref true in - let copy_subst c newset = - let c' = subst_mps subst c in - if not (c' == c) then same := false; - ConstrSet.add c' newset - in - let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in - if !same then cset else cset' - -let subst_theory subst th = - let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in - let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in - let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in - let th_a' = subst_mps subst th.th_a in - let th_plus' = subst_mps subst th.th_plus in - let th_mult' = subst_mps subst th.th_mult in - let th_one' = subst_mps subst th.th_one in - let th_zero' = subst_mps subst th.th_zero in - let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in - let th_eq' = subst_mps subst th.th_eq in - let th_t' = subst_mps subst th.th_t in - let th_closed' = subst_set subst th.th_closed in - if th_equiv' == th.th_equiv - && th_setoid_th' == th.th_setoid_th - && th_morph' == th.th_morph - && th_a' == th.th_a - && th_plus' == th.th_plus - && th_mult' == th.th_mult - && th_one' == th.th_one - && th_zero' == th.th_zero - && th_opp' == th.th_opp - && th_eq' == th.th_eq - && th_t' == th.th_t - && th_closed' == th.th_closed - then - th - else - { th_ring = th.th_ring ; - th_abstract = th.th_abstract ; - th_setoid = th.th_setoid ; - th_equiv = th_equiv' ; - th_setoid_th = th_setoid_th' ; - th_morph = th_morph' ; - th_a = th_a' ; - th_plus = th_plus' ; - th_mult = th_mult' ; - th_one = th_one' ; - th_zero = th_zero' ; - th_opp = th_opp' ; - th_eq = th_eq' ; - th_t = th_t' ; - th_closed = th_closed' ; - } - - -let subst_th (_,subst,(c,th as obj)) = - let c' = subst_mps subst c in - let th' = subst_theory subst th in - if c' == c && th' == th then obj else - (c',th') - - -let (theory_to_obj, obj_to_theory) = - let cache_th (_,(c, th)) = theories_map_add (c,th) - and export_th x = Some x in - declare_object {(default_object "tactic-ring-theory") with - open_function = (fun i o -> if i=1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_th } - -(* from the set A, guess the associated theory *) -(* With this simple solution, the theory to use is automatically guessed *) -(* But only one theory can be declared for a given Set *) - -let guess_theory a = - try - theories_map_find a - with Not_found -> - errorlabstrm "Ring" - (str "No Declared Ring Theory for " ++ - pr_lconstr a ++ fnl () ++ - str "Use Add [Semi] Ring to declare it") - -(* Looks up an option *) - -let unbox = function - | Some w -> w - | None -> anomaly "Ring : Not in case of a setoid ring." - -(* Protects the convertibility test against undue exceptions when using it - with untyped terms *) - -let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false - - -(* Add a Ring or a Semi-Ring to the database after a type verification *) - -let implement_theory env t th args = - is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) - -(* (\* The following test checks whether the provided morphism is the default *) -(* one for the given operation. In principle the test is too strict, since *) -(* it should possible to provide another proof for the same fact (proof *) -(* irrelevance). In particular, the error message is be not very explicative. *\) *) -let states_compatibility_for env plus mult opp morphs = - let check op compat = true in -(* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *) -(* compat in *) - check plus morphs.plusm && - check mult morphs.multm && - (match (opp,morphs.oppm) with - None, None -> true - | Some opp, Some compat -> check opp compat - | _,_ -> assert false) - -let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = - if theories_map_mem a then errorlabstrm "Add Semi Ring" - (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ - pr_lconstr a); - let env = Global.env () in - if (want_ring & want_setoid & ( - not (implement_theory env t coq_Setoid_Ring_Theory - [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|]) - || - not (implement_theory env (unbox asetth) coq_Setoid_Theory - [| a; (unbox aequiv) |]) || - not (states_compatibility_for env aplus amult aopp (unbox amorph)) - )) then - errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); - if (not want_ring & want_setoid & ( - not (implement_theory env t coq_Semi_Setoid_Ring_Theory - [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || - not (implement_theory env (unbox asetth) coq_Setoid_Theory - [| a; (unbox aequiv) |]) || - not (states_compatibility_for env aplus amult aopp (unbox amorph)))) - then - errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory"); - if (want_ring & not want_setoid & - not (implement_theory env t coq_Ring_Theory - [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then - errorlabstrm "addring" (str "Not a valid Ring theory"); - if (not want_ring & not want_setoid & - not (implement_theory env t coq_Semi_Ring_Theory - [| a; aplus; amult; aone; azero; aeq |])) then - errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); - Lib.add_anonymous_leaf - (theory_to_obj - (a, { th_ring = want_ring; - th_abstract = want_abstract; - th_setoid = want_setoid; - th_equiv = aequiv; - th_setoid_th = asetth; - th_morph = amorph; - th_a = a; - th_plus = aplus; - th_mult = amult; - th_one = aone; - th_zero = azero; - th_opp = aopp; - th_eq = aeq; - th_t = t; - th_closed = cset })) - -(******** The tactic itself *********) - -(* - gl : goal sigma - th : semi-ring theory (concrete) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_spolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the spolynom p by a recursive destructuration of c - and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) - | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) - | _ when closed_under th.th_closed c -> - mkLApp(coq_SPconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> - (mkLApp (coq_interp_sp, - [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), - mkLApp (coq_interp_cs, - [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp (coq_spolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; - th.th_eq; p|])) |]), - mkLApp (coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; v; th.th_t; p |]))) - lp - -(* - gl : goal sigma - th : ring theory (concrete) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_polynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) - (* The special case of Zminus *) - | App (binop, [|c1; c2|]) - when safe_pf_conv_x gl c - (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> - mkLApp(coq_Pplus, - [|th.th_a; aux c1; - mkLApp(coq_Popp, [|th.th_a; aux c2|]) |]) - | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> - mkLApp(coq_Popp, [|th.th_a; aux c1|]) - | _ when closed_under th.th_closed c -> - mkLApp(coq_Pconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> - (mkLApp(coq_interp_p, - [| th.th_a; th.th_plus; th.th_mult; th.th_zero; - (unbox th.th_opp); v; p |])), - mkLApp(coq_interp_cs, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp(coq_polynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; p |])) |]), - mkLApp(coq_polynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) - lp - -(* - gl : goal sigma - th : semi-ring theory (abstract) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_aspolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the aspolynom p by a recursive destructuration of c - and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) - | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 - | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> - (mkLApp(coq_interp_asp, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; v; p |]), - mkLApp(coq_interp_acs, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), - mkLApp(coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; v; th.th_t; p |]))) - lp - -(* - gl : goal sigma - th : ring theory (abstract) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_apolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_APplus, [| aux c1; aux c2 |]) - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_APmult, [| aux c1; aux c2 |]) - (* The special case of Zminus *) - | App (binop, [|c1; c2|]) - when safe_pf_conv_x gl c - (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> - mkLApp(coq_APplus, - [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |]) - | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> - mkLApp(coq_APopp, [| aux c1 |]) - | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 - | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_APvar, [| path_of_int !counter |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> - (mkLApp(coq_interp_ap, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; - th.th_zero; (unbox th.th_opp); v; p |]), - mkLApp(coq_interp_sacs, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; (unbox th.th_opp); v; - pf_reduce cbv_betadeltaiota gl - (mkLApp(coq_apolynomial_normalize, [|p|])) |]), - mkLApp(coq_apolynomial_normalize_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) - lp - -(* - gl : goal sigma - th : setoid ring theory (concrete) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_setpolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) - (* The special case of Zminus *) - | App (binop, [|c1; c2|]) - when safe_pf_conv_x gl c - (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> - mkLApp(coq_SetPplus, - [| th.th_a; aux c1; - mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |]) - | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> - mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) - | _ when closed_under th.th_closed c -> - mkLApp(coq_SetPconst, [| th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> - (mkLApp(coq_interp_setp, - [| th.th_a; th.th_plus; th.th_mult; th.th_zero; - (unbox th.th_opp); v; p |]), - mkLApp(coq_interp_setcs, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp(coq_setpolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; p |])) |]), - mkLApp(coq_setpolynomial_simplify_ok, - [| th.th_a; (unbox th.th_equiv); th.th_plus; - th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp); - th.th_eq; (unbox th.th_setoid_th); - (unbox th.th_morph).plusm; (unbox th.th_morph).multm; - (unbox (unbox th.th_morph).oppm); v; th.th_t; p |]))) - lp - -(* - gl : goal sigma - th : semi setoid ring theory (concrete) - cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] - where c'i is convertible with ci and - c'i_eq_c''i is a proof of equality of c'i and c''i - -*) - -let build_setspolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in - let varlist = ref ([] : constr list) in (* list of variables *) - let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> - mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) - | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> - mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) - | _ when closed_under th.th_closed c -> - mkLApp(coq_SetSPconst, [| th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> - let newvar = - mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in - begin - incr counter; - varlist := c :: !varlist; - Hashtbl.add varhash c newvar; - newvar - end - in - let lp = List.map aux lc in - let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> - (mkLApp(coq_interp_setsp, - [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), - mkLApp(coq_interp_setcs, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp(coq_setspolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; - th.th_eq; p |])) |]), - mkLApp(coq_setspolynomial_simplify_ok, - [| th.th_a; (unbox th.th_equiv); th.th_plus; - th.th_mult; th.th_one; th.th_zero; th.th_eq; - (unbox th.th_setoid_th); - (unbox th.th_morph).plusm; - (unbox th.th_morph).multm; v; th.th_t; p |]))) - lp - -module SectionPathSet = - Set.Make(struct - type t = section_path - let compare = Pervasives.compare - end) - -(* Avec l'uniformisation des red_kind, on perd ici sur la structure - SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *) -let constants_to_unfold = -(* List.fold_right SectionPathSet.add *) - let transform s = - let sp = path_of_string s in - let dir, id = repr_path sp in - Libnames.encode_con dir id - in - List.map transform - [ "Coq.ring.Ring_normalize.interp_cs"; - "Coq.ring.Ring_normalize.interp_var"; - "Coq.ring.Ring_normalize.interp_vl"; - "Coq.ring.Ring_abstract.interp_acs"; - "Coq.ring.Ring_abstract.interp_sacs"; - "Coq.ring.Quote.varmap_find"; - (* anciennement des Local devenus Definition *) - "Coq.ring.Ring_normalize.ics_aux"; - "Coq.ring.Ring_normalize.ivl_aux"; - "Coq.ring.Ring_normalize.interp_m"; - "Coq.ring.Ring_abstract.iacs_aux"; - "Coq.ring.Ring_abstract.isacs_aux"; - "Coq.ring.Setoid_ring_normalize.interp_cs"; - "Coq.ring.Setoid_ring_normalize.interp_var"; - "Coq.ring.Setoid_ring_normalize.interp_vl"; - "Coq.ring.Setoid_ring_normalize.ics_aux"; - "Coq.ring.Setoid_ring_normalize.ivl_aux"; - "Coq.ring.Setoid_ring_normalize.interp_m"; - ] -(* SectionPathSet.empty *) - -(* Unfolds the functions interp and find_btree in the term c of goal gl *) -open RedFlags -let polynom_unfold_tac = - let flags = - (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in - reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) - -let polynom_unfold_tac_in_term gl = - let flags = - (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) - in - cbv_norm_flags flags (pf_env gl) (project gl) - -(* lc : constr list *) -(* th : theory associated to t *) -(* op : clause (None for conclusion or Some id for hypothesis id) *) -(* gl : goal *) -(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) - where the ring R, the Ring theory RC, the varmap v and the polynomials p_i - are guessed and such that c_i = (interp R RC v p_i) *) -let raw_polynom th op lc gl = - (* first we sort the terms : if t' is a subterm of t it must appear - after t in the list. This is to avoid that the normalization of t' - modifies t in a non-desired way *) - let lc = sort_subterm gl lc in - let ltriplets = - if th.th_setoid then - if th.th_ring - then build_setpolynom gl th lc - else build_setspolynom gl th lc - else - if th.th_ring then - if th.th_abstract - then build_apolynom gl th lc - else build_polynom gl th lc - else - if th.th_abstract - then build_aspolynom gl th lc - else build_spolynom gl th lc in - let polynom_tac = - List.fold_right2 - (fun ci (c'i, c''i, c'i_eq_c''i) tac -> - let c'''i = - if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i - in - if !term_quality && safe_pf_conv_x gl c'''i ci then - tac (* convertible terms *) - else if th.th_setoid - then - (tclORELSE - (tclORELSE - (h_exact c'i_eq_c''i) - (h_exact (mkLApp(coq_seq_sym, - [| th.th_a; (unbox th.th_equiv); - (unbox th.th_setoid_th); - c'''i; ci; c'i_eq_c''i |])))) - (tclTHENS - (tclORELSE - (Equality.general_rewrite true - Termops.all_occurrences c'i_eq_c''i) - (Equality.general_rewrite false - Termops.all_occurrences c'i_eq_c''i)) - [tac])) - else - (tclORELSE - (tclORELSE - (h_exact c'i_eq_c''i) - (h_exact (mkApp(build_coq_sym_eq (), - [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) - (tclTHENS - (elim_type - (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) - [ tac; - h_exact c'i_eq_c''i ])) -) - lc ltriplets polynom_unfold_tac - in - polynom_tac gl - -let guess_eq_tac th = - (tclORELSE reflexivity - (tclTHEN - polynom_unfold_tac - (tclTHEN - (* Normalized sums associate on the right *) - (tclREPEAT - (tclTHENFIRST - (apply (mkApp(build_coq_f_equal2 (), - [| th.th_a; th.th_a; th.th_a; - th.th_plus |]))) - reflexivity)) - (tclTRY - (tclTHENLAST - (apply (mkApp(build_coq_f_equal2 (), - [| th.th_a; th.th_a; th.th_a; - th.th_plus |]))) - reflexivity))))) - -let guess_equiv_tac th = - (tclORELSE (apply (mkLApp(coq_seq_refl, - [| th.th_a; (unbox th.th_equiv); - (unbox th.th_setoid_th)|]))) - (tclTHEN - polynom_unfold_tac - (tclREPEAT - (tclORELSE - (apply (unbox th.th_morph).plusm) - (apply (unbox th.th_morph).multm))))) - -let match_with_equiv c = match (kind_of_term c) with - | App (e,a) -> - if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) - then Some (decompose_app c) - else None - | _ -> None - -let polynom lc gl = - Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; - match lc with - (* If no argument is given, try to recognize either an equality or - a declared relation with arguments c1 ... cn, - do "Ring c1 c2 ... cn" and then try to apply the simplification - theorems declared for the relation *) - | [] -> - (match Hipattern.match_with_equation (pf_concl gl) with - | Some (eq,t::args) -> - let th = guess_theory t in - if List.exists - (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) args - then - errorlabstrm "Ring :" - (str" All terms must have the same type"); - (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl - | _ -> (match match_with_equiv (pf_concl gl) with - | Some (equiv, c1::args) -> - let t = (pf_type_of gl c1) in - let th = (guess_theory t) in - if List.exists - (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args - then - errorlabstrm "Ring :" - (str" All terms must have the same type"); - (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl - | _ -> errorlabstrm "polynom :" - (str" This goal is not an equality nor a setoid equivalence"))) - (* Elsewhere, guess the theory, check that all terms have the same type - and apply raw_polynom *) - | c :: lc' -> - let t = pf_type_of gl c in - let th = guess_theory t in - if List.exists - (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' - then - errorlabstrm "Ring :" - (str" All terms must have the same type"); - (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl diff --git a/contrib/romega/README b/contrib/romega/README deleted file mode 100644 index 86c9e58a..00000000 --- a/contrib/romega/README +++ /dev/null @@ -1,6 +0,0 @@ -This work was done for the RNRT Project Calife. -As such it is distributed under the LGPL licence. - -Report bugs to : - pierre.cregut@francetelecom.com - diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v deleted file mode 100644 index 4281cc57..00000000 --- a/contrib/romega/ROmega.v +++ /dev/null @@ -1,12 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -Require Import ReflOmegaCore. -Require Export Setoid. -Require Export PreOmega. -Require Export ZArith_base. diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v deleted file mode 100644 index 12176d66..00000000 --- a/contrib/romega/ReflOmegaCore.v +++ /dev/null @@ -1,3216 +0,0 @@ -(* -*- coding: utf-8 -*- *) -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence du projet : LGPL version 2.1 - - *************************************************************************) - -Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. -Delimit Scope Int_scope with I. - -(* Abstract Integers. *) - -Module Type Int. - - Parameter int : Set. - - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. - Parameter opp : int -> int. - Parameter minus : int -> int -> int. - Parameter mult : int -> int -> int. - - Notation "0" := zero : Int_scope. - Notation "1" := one : Int_scope. - Infix "+" := plus : Int_scope. - Infix "-" := minus : Int_scope. - Infix "*" := mult : Int_scope. - Notation "- x" := (opp x) : Int_scope. - - Open Scope Int_scope. - - (* First, int is a ring: *) - Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). - - (* int should also be ordered: *) - - Parameter le : int -> int -> Prop. - Parameter lt : int -> int -> Prop. - Parameter ge : int -> int -> Prop. - Parameter gt : int -> int -> Prop. - Notation "x <= y" := (le x y): Int_scope. - Notation "x < y" := (lt x y) : Int_scope. - Notation "x >= y" := (ge x y) : Int_scope. - Notation "x > y" := (gt x y): Int_scope. - Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i). - Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). - Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i). - - (* Basic properties of this order *) - Axiom lt_trans : forall i j k, i<j -> j<k -> i<k. - Axiom lt_not_eq : forall i j, i<j -> i<>j. - - (* Compatibilities *) - Axiom lt_0_1 : 0<1. - Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. - Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Axiom mult_lt_compat_l : - forall i j k, 0 < k -> i < j -> k*i<k*j. - - (* We should have a way to decide the equality and the order*) - Parameter compare : int -> int -> comparison. - Infix "?=" := compare (at level 70, no associativity) : Int_scope. - Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. - Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. - Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j. - - (* Up to here, these requirements could be fulfilled - by any totally ordered ring. Let's now be int-specific: *) - Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1). - - (* Btw, lt_0_1 could be deduced from this last axiom *) - -End Int. - - - -(* Of course, Z is a model for our abstract int *) - -Module Z_as_Int <: Int. - - Open Scope Z_scope. - - Definition int := Z. - Definition zero := 0. - Definition one := 1. - Definition plus := Zplus. - Definition opp := Zopp. - Definition minus := Zminus. - Definition mult := Zmult. - - Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int). - Proof. - constructor. - exact Zplus_0_l. - exact Zplus_comm. - exact Zplus_assoc. - exact Zmult_1_l. - exact Zmult_comm. - exact Zmult_assoc. - exact Zmult_plus_distr_l. - unfold minus, Zminus; auto. - exact Zplus_opp_r. - Qed. - - Definition le := Zle. - Definition lt := Zlt. - Definition ge := Zge. - Definition gt := Zgt. - Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i). - Proof. - split; intros. - apply Zle_not_lt; auto. - rewrite <- Zge_iff_le. - apply Znot_lt_ge; auto. - Qed. - Definition ge_le_iff := Zge_iff_le. - Definition gt_lt_iff := Zgt_iff_lt. - - Definition lt_trans := Zlt_trans. - Definition lt_not_eq := Zlt_not_eq. - - Definition lt_0_1 := Zlt_0_1. - Definition plus_le_compat := Zplus_le_compat. - Definition mult_lt_compat_l := Zmult_lt_compat_l. - Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Proof. - unfold Zle; intros; rewrite <- Zcompare_opp; auto. - Qed. - - Definition compare := Zcompare. - Definition compare_Eq := Zcompare_Eq_iff_eq. - Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j. - Proof. intros; unfold compare, Zlt; intuition. Qed. - Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j. - Proof. intros; unfold compare, Zgt; intuition. Qed. - - Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1). - Proof. - intros; split; intros. - generalize (Zlt_left _ _ H); simpl; intros. - apply Zle_left_rev; auto. - apply Zlt_0_minus_lt. - generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H). - rewrite Zplus_opp_r. - rewrite <-Zplus_assoc. - rewrite (Zplus_permute (-1)). - simpl in *. - rewrite Zplus_0_r. - intro H'; apply H'. - replace (-x+1) with (Zsucc (-x)); auto. - apply Zlt_succ. - Qed. - -End Z_as_Int. - - - - -Module IntProperties (I:Int). - Import I. - - (* Primo, some consequences of being a ring theory... *) - - Definition two := 1+1. - Notation "2" := two : Int_scope. - - (* Aliases for properties packed in the ring record. *) - - Definition plus_assoc := ring.(Radd_assoc). - Definition plus_comm := ring.(Radd_comm). - Definition plus_0_l := ring.(Radd_0_l). - Definition mult_assoc := ring.(Rmul_assoc). - Definition mult_comm := ring.(Rmul_comm). - Definition mult_1_l := ring.(Rmul_1_l). - Definition mult_plus_distr_r := ring.(Rdistr_l). - Definition opp_def := ring.(Ropp_def). - Definition minus_def := ring.(Rsub_def). - - Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l - mult_plus_distr_r opp_def minus_def. - - (* More facts about plus *) - - Lemma plus_0_r : forall x, x+0 = x. - Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. - - Lemma plus_0_r_reverse : forall x, x = x+0. - Proof. intros; symmetry; apply plus_0_r. Qed. - - Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). - Proof. intros; symmetry; apply plus_assoc. Qed. - - Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z). - Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. - - Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. - Proof. - intros. - rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). - now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. - Qed. - - (* More facts about mult *) - - Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). - Proof. intros; symmetry; apply mult_assoc. Qed. - - Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z. - Proof. - intros. - rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z). - apply mult_plus_distr_r. - Qed. - - Lemma mult_0_l : forall x, 0*x = 0. - Proof. - intros. - generalize (mult_plus_distr_r 0 1 x). - rewrite plus_0_l, mult_1_l, plus_comm; intros. - apply plus_reg_l with x. - rewrite <- H. - apply plus_0_r_reverse. - Qed. - - - (* More facts about opp *) - - Definition plus_opp_r := opp_def. - - Lemma plus_opp_l : forall x, -x + x = 0. - Proof. intros; now rewrite plus_comm, opp_def. Qed. - - Lemma mult_opp_comm : forall x y, - x * y = x * - y. - Proof. - intros. - apply plus_reg_l with (x*y). - rewrite <- mult_plus_distr_l, <- mult_plus_distr_r. - now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l. - Qed. - - Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1). - Proof. - intros; now rewrite mult_comm, mult_opp_comm, mult_1_l. - Qed. - - Lemma opp_involutive : forall x, -(-x) = x. - Proof. - intros. - apply plus_reg_l with (-x). - now rewrite opp_def, plus_comm, opp_def. - Qed. - - Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y. - Proof. - intros. - apply plus_reg_l with (x+y). - rewrite opp_def. - rewrite plus_permute. - do 2 rewrite plus_assoc. - now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def. - Qed. - - Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y. - Proof. - intros. - rewrite <- mult_opp_comm. - apply plus_reg_l with (x*y). - now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. - Qed. - - Lemma egal_left : forall n m, n=m -> n+-m = 0. - Proof. intros; subst; apply opp_def. Qed. - - Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). - Proof. - intros; contradict H. - apply (plus_reg_l (-y)). - now rewrite plus_opp_l, plus_comm, H. - Qed. - - (* Special lemmas for factorisation. *) - - Lemma red_factor0 : forall n, n = n*1. - Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. - - Lemma red_factor1 : forall n, n+n = n*2. - Proof. - intros; unfold two. - now rewrite mult_comm, mult_plus_distr_r, mult_1_l. - Qed. - - Lemma red_factor2 : forall n m, n + n*m = n * (1+m). - Proof. - intros; rewrite mult_plus_distr_l. - f_equal; now rewrite mult_comm, mult_1_l. - Qed. - - Lemma red_factor3 : forall n m, n*m + n = n*(1+m). - Proof. intros; now rewrite plus_comm, red_factor2. Qed. - - Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). - Proof. - intros; now rewrite mult_plus_distr_l. - Qed. - - Lemma red_factor5 : forall n m , n * 0 + m = m. - Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. - - Definition red_factor6 := plus_0_r_reverse. - - - (* Specialized distributivities *) - - Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. - Hint Rewrite <- plus_assoc : int. - - Lemma OMEGA10 : - forall v c1 c2 l1 l2 k1 k2 : int, - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). - Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - - Lemma OMEGA11 : - forall v1 c1 l1 l2 k1 : int, - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). - Proof. - intros; now autorewrite with int. - Qed. - - Lemma OMEGA12 : - forall v2 c2 l1 l2 k2 : int, - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). - Proof. - intros; autorewrite with int; now rewrite plus_permute. - Qed. - - Lemma OMEGA13 : - forall v l1 l2 x : int, - v * -x + l1 + (v * x + l2) = l1 + l2. - Proof. - intros; autorewrite with int. - rewrite plus_permute; f_equal. - rewrite plus_assoc. - now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. - Qed. - - Lemma OMEGA15 : - forall v c1 c2 l1 l2 k2 : int, - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). - Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - - Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. - Proof. - intros; now autorewrite with int. - Qed. - - Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. - Proof. - intros; elim H; elim H0; simpl in |- *; auto. - now rewrite mult_0_l, mult_0_l, plus_0_l. - Qed. - - - (* Secondo, some results about order (and equality) *) - - Lemma lt_irrefl : forall n, ~ n<n. - Proof. - intros n H. - elim (lt_not_eq _ _ H); auto. - Qed. - - Lemma lt_antisym : forall n m, n<m -> m<n -> False. - Proof. - intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto. - Qed. - - Lemma lt_le_weak : forall n m, n<m -> n<=m. - Proof. - intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto. - Qed. - - Lemma le_refl : forall n, n<=n. - Proof. - intros; rewrite le_lt_iff; apply lt_irrefl; auto. - Qed. - - Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m. - Proof. - intros n m; do 2 rewrite le_lt_iff; intros. - rewrite <- compare_Lt in H0. - rewrite <- gt_lt_iff, <- compare_Gt in H. - rewrite <- compare_Eq. - destruct compare; intuition. - Qed. - - Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ left; right | left; left | right ]; intuition. - rewrite gt_lt_iff in H1; intuition. - Qed. - - Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }. - Proof. - intros. - generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m). - destruct compare; [ right | left | right ]; intuition discriminate. - Qed. - - Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n). - Proof. - intros. - rewrite le_lt_iff. - destruct (lt_dec n m); intuition. - Qed. - - Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }. - Proof. - intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition. - Qed. - - Lemma le_lt_dec : forall n m, { n<=m } + { m<n }. - Proof. - intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff. - Qed. - - - Definition beq i j := match compare i j with Eq => true | _ => false end. - - Lemma beq_iff : forall i j, beq i j = true <-> i=j. - Proof. - intros; unfold beq; generalize (compare_Eq i j). - destruct compare; intuition discriminate. - Qed. - - Lemma beq_true : forall i j, beq i j = true -> i=j. - Proof. - intros. - rewrite <- beq_iff; auto. - Qed. - - Lemma beq_false : forall i j, beq i j = false -> i<>j. - Proof. - intros. - intro H'. - rewrite <- beq_iff in H'; rewrite H' in H; discriminate. - Qed. - - Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. - Proof. - intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. - Qed. - - Definition bgt i j := match compare i j with Gt => true | _ => false end. - - Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. - Proof. - intros; unfold bgt; generalize (compare_Gt i j). - destruct compare; intuition discriminate. - Qed. - - Lemma bgt_true : forall i j, bgt i j = true -> i>j. - Proof. intros; now rewrite <- bgt_iff. Qed. - - Lemma bgt_false : forall i j, bgt i j = false -> i<=j. - Proof. - intros. - rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. - Qed. - - Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }. - Proof. - intros. - destruct (eq_dec n m) as [H'|H']. - right; intuition. - left; rewrite lt_le_iff. - contradict H'. - apply le_antisym; auto. - Qed. - - Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m. - Proof. - intros. - destruct (le_is_lt_or_eq _ _ H); intuition. - Qed. - - Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p. - Proof. - intros n m p; do 3 rewrite le_lt_iff; intros A B C. - destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. - generalize (lt_trans _ _ _ H C); intuition. - Qed. - - (* order and operations *) - - Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. - Proof. - intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). - rewrite <- opp_eq_mult_neg_1. - split; intros. - apply opp_le_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_le_compat; auto. - Qed. - - Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. - Proof. - intros; rewrite le_0_neg, opp_involutive; intuition. - Qed. - - Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. - Proof. - intros. - replace n with ((n+p)+-p). - replace m with ((m+p)+-p). - apply plus_le_compat; auto. - apply le_refl. - now rewrite <- plus_assoc, opp_def, plus_0_r. - now rewrite <- plus_assoc, opp_def, plus_0_r. - Qed. - - Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q. - Proof. - intros. - apply le_neq_lt. - apply plus_le_compat; auto. - apply lt_le_weak; auto. - rewrite lt_le_iff in H0. - contradict H0. - apply plus_le_reg_r with m. - rewrite (plus_comm q m), <-H0, (plus_comm p m). - apply plus_le_compat; auto. - apply le_refl; auto. - Qed. - - Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q. - Proof. - intros. - apply plus_le_lt_compat; auto. - apply lt_le_weak; auto. - Qed. - - Lemma opp_lt_compat : forall n m, n<m -> -m < -n. - Proof. - intros n m; do 2 rewrite lt_le_iff; intros H; contradict H. - rewrite <-(opp_involutive m), <-(opp_involutive n). - apply opp_le_compat; auto. - Qed. - - Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. - Proof. - intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). - rewrite <- opp_eq_mult_neg_1. - split; intros. - apply opp_lt_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_lt_compat; auto. - Qed. - - Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. - Proof. - intros; rewrite lt_0_neg, opp_involutive; intuition. - Qed. - - Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. - Proof. - intros. - rewrite <- (mult_0_l n), mult_comm. - apply mult_lt_compat_l; auto. - Qed. - - Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. - Proof. - intros. - destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; - destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; elimtype False. - - rewrite lt_0_neg' in Hn. - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. - rewrite mult_comm, H. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hn. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite mult_comm, <- opp_mult_distr_r, mult_comm. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite H. - exact (lt_irrefl 0). - Qed. - - Lemma mult_le_compat : - forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. - Proof. - intros. - destruct (le_is_lt_or_eq _ _ H1). - - apply le_trans with (i*l). - destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. - - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - rewrite (mult_comm i), (mult_comm j). - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; do 2 rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. - - subst i. - rewrite mult_0_l. - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. - apply lt_le_weak. - apply mult_lt_0_compat; auto. - Qed. - - Lemma sum5 : - forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. - Proof. - intros. - subst b; rewrite mult_0_l, plus_0_r. - contradict H. - symmetry in H; destruct (mult_integral _ _ H); congruence. - Qed. - - Lemma one_neq_zero : 1 <> 0. - Proof. - red; intro. - symmetry in H. - apply (lt_not_eq 0 1); auto. - apply lt_0_1. - Qed. - - Lemma minus_one_neq_zero : -(1) <> 0. - Proof. - apply lt_not_eq. - rewrite <- lt_0_neg. - apply lt_0_1. - Qed. - - Lemma le_left : forall n m, n <= m -> 0 <= m + - n. - Proof. - intros. - rewrite <- (opp_def m). - apply plus_le_compat. - apply le_refl. - apply opp_le_compat; auto. - Qed. - - Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. - Proof. - intros. - replace 0 with (0+0). - apply plus_le_compat; auto. - rewrite plus_0_l; auto. - Qed. - - Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. - Proof. - intros. - assert (y=-x). - subst x; symmetry; apply opp_involutive. - clear H1; subst y. - destruct (eq_dec 0 x) as [H'|H']; auto. - assert (H'':=le_neq_lt _ _ H H'). - generalize (plus_le_lt_compat _ _ _ _ H0 H''). - rewrite plus_opp_l, plus_0_l. - intros. - elim (lt_not_eq _ _ H1); auto. - Qed. - - Lemma sum2 : - forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros. - subst a; rewrite mult_0_l, plus_0_l. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - Lemma sum3 : - forall a b c d : int, - 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. - Proof. - intros. - rewrite <- (plus_0_l 0). - apply plus_le_compat; auto. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - rewrite <- (mult_0_l 0). - apply mult_le_compat; auto; apply le_refl. - Qed. - - Lemma sum4 : forall k : int, k>0 -> 0 <= k. - Proof. - intros k; rewrite gt_lt_iff; apply lt_le_weak. - Qed. - - (* Lemmas specific to integers (they use lt_le_int) *) - - Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. - Proof. - intros; apply le_left. - now rewrite <- le_lt_int. - Qed. - - Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. - Proof. - intros. - generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. - now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. - Qed. - - Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. - Proof. - intros. - intro H'. - rewrite gt_lt_iff in H,H0. - destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - - rewrite lt_0_neg' in G. - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). - rewrite H'. - pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. - intros. - rewrite le_lt_int in G. - rewrite <- opp_plus_distr in G. - assert (0 < y) by (apply lt_trans with x; auto). - generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). - rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. - intuition. - - subst; rewrite mult_0_l, plus_0_l in H'; subst. - apply (lt_not_eq _ _ H); auto. - - apply (lt_not_eq 0 (z*y+x)); auto. - rewrite <- (plus_0_l 0). - apply plus_lt_compat; auto. - apply mult_lt_0_compat; auto. - apply lt_trans with x; auto. - Qed. - - Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). - Proof. - intros. - do 2 rewrite <- le_lt_int. - rewrite <- opp_eq_mult_neg_1. - destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H']. - auto. - congruence. - right. - rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0). - apply opp_lt_compat; auto. - Qed. - - Lemma mult_le_approx : - forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. - Proof. - intros n m p. - do 2 rewrite gt_lt_iff. - do 2 rewrite le_lt_iff; intros. - contradict H1. - rewrite lt_0_neg' in H1. - rewrite lt_0_neg'. - rewrite opp_plus_distr. - rewrite mult_comm, opp_mult_distr_r. - rewrite le_lt_int. - rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. - apply lt_left. - rewrite le_lt_int. - rewrite le_lt_int in H0. - apply le_trans with (n+-(1)); auto. - apply plus_le_compat; [ | apply le_refl ]. - rewrite le_lt_int in H1. - generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). - rewrite mult_0_l. - rewrite mult_plus_distr_l. - rewrite <- opp_eq_mult_neg_1. - intros. - generalize (plus_le_compat _ _ _ _ (le_refl n) H2). - now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. - Qed. - - (* Some decidabilities *) - - Lemma dec_eq : forall i j:int, decidable (i=j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_ne : forall i j:int, decidable (i<>j). - Proof. - red; intros; destruct (eq_dec i j); auto. - Qed. - - Lemma dec_le : forall i j:int, decidable (i<=j). - Proof. - red; intros; destruct (le_dec i j); auto. - Qed. - - Lemma dec_lt : forall i j:int, decidable (i<j). - Proof. - red; intros; destruct (lt_dec i j); auto. - Qed. - - Lemma dec_ge : forall i j:int, decidable (i>=j). - Proof. - red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto. - Qed. - - Lemma dec_gt : forall i j:int, decidable (i>j). - Proof. - red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto. - Qed. - -End IntProperties. - - - - -Module IntOmega (I:Int). -Import I. -Module IP:=IntProperties(I). -Import IP. - -(* \subsubsection{Definition of reified integer expressions} - Terms are either: - \begin{itemize} - \item integers [Tint] - \item variables [Tvar] - \item operation over integers (addition, product, opposite, subtraction) - The last two are translated in additions and products. *) - -Inductive term : Set := - | Tint : int -> term - | Tplus : term -> term -> term - | Tmult : term -> term -> term - | Tminus : term -> term -> term - | Topp : term -> term - | Tvar : nat -> term. - -Delimit Scope romega_scope with term. -Arguments Scope Tint [Int_scope]. -Arguments Scope Tplus [romega_scope romega_scope]. -Arguments Scope Tmult [romega_scope romega_scope]. -Arguments Scope Tminus [romega_scope romega_scope]. -Arguments Scope Topp [romega_scope romega_scope]. - -Infix "+" := Tplus : romega_scope. -Infix "*" := Tmult : romega_scope. -Infix "-" := Tminus : romega_scope. -Notation "- x" := (Topp x) : romega_scope. -Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. - -(* \subsubsection{Definition of reified goals} *) - -(* Very restricted definition of handled predicates that should be extended - to cover a wider set of operations. - Taking care of negations and disequations require solving more than a - goal in parallel. This is a major improvement over previous versions. *) - -Inductive proposition : Set := - | EqTerm : term -> term -> proposition (* equality between terms *) - | LeqTerm : term -> term -> proposition (* less or equal on terms *) - | TrueTerm : proposition (* true *) - | FalseTerm : proposition (* false *) - | Tnot : proposition -> proposition (* negation *) - | GeqTerm : term -> term -> proposition - | GtTerm : term -> term -> proposition - | LtTerm : term -> term -> proposition - | NeqTerm : term -> term -> proposition - | Tor : proposition -> proposition -> proposition - | Tand : proposition -> proposition -> proposition - | Timp : proposition -> proposition -> proposition - | Tprop : nat -> proposition. - -(* Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition). - -(* Definition of lists of subgoals (set of open goals) *) -Notation lhyps := (list hyps). - -(* a single goal packed in a subgoal list *) -Notation singleton := (fun a : hyps => a :: nil). - -(* an absurd goal *) -Definition absurd := FalseTerm :: nil. - -(* \subsubsection{Traces for merging equations} - This inductive type describes how the monomial of two equations should be - merged when the equations are added. - - For [F_equal], both equations have the same head variable and coefficient - must be added, furthermore if coefficients are opposite, [F_cancel] should - be used to collapse the term. [F_left] and [F_right] indicate which monomial - should be put first in the result *) - -Inductive t_fusion : Set := - | F_equal : t_fusion - | F_cancel : t_fusion - | F_left : t_fusion - | F_right : t_fusion. - -(* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := - (* apply the rewriting steps to both subterms of an operation *) - | C_DO_BOTH : step -> step -> step - (* apply the rewriting step to the first branch *) - | C_LEFT : step -> step - (* apply the rewriting step to the second branch *) - | C_RIGHT : step -> step - (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step - (* empty step *) - | C_NOP : step - (* the following operations correspond to actual rewriting *) - | C_OPP_PLUS : step - | C_OPP_OPP : step - | C_OPP_MULT_R : step - | C_OPP_ONE : step - (* This is a special step that reduces the term (computation) *) - | C_REDUCE : step - | C_MULT_PLUS_DISTR : step - | C_MULT_OPP_LEFT : step - | C_MULT_ASSOC_R : step - | C_PLUS_ASSOC_R : step - | C_PLUS_ASSOC_L : step - | C_PLUS_PERMUTE : step - | C_PLUS_COMM : step - | C_RED0 : step - | C_RED1 : step - | C_RED2 : step - | C_RED3 : step - | C_RED4 : step - | C_RED5 : step - | C_RED6 : step - | C_MULT_ASSOC_REDUCED : step - | C_MINUS : step - | C_MULT_COMM : step. - -(* \subsubsection{Omega steps} *) -(* The following inductive type describes steps as they can be found in - the trace coming from the decision procedure Omega. *) - -Inductive t_omega : Set := - (* n = 0 and n!= 0 *) - | O_CONSTANT_NOT_NUL : nat -> t_omega - | O_CONSTANT_NEG : nat -> t_omega - (* division and approximation of an equation *) - | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega - (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega - (* exact division *) - | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega - | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega - | O_CONTRADICTION : nat -> nat -> nat -> t_omega - | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega - | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega - | O_CONSTANT_NUL : nat -> t_omega - | O_NEGATE_CONTRADICT : nat -> nat -> t_omega - | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega - | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. - -(* \subsubsection{Rules for normalizing the hypothesis} *) -(* These rules indicate how to normalize useful propositions - of each useful hypothesis before the decomposition of hypothesis. - The rules include the inversion phase for negation removal. *) - -Inductive p_step : Set := - | P_LEFT : p_step -> p_step - | P_RIGHT : p_step -> p_step - | P_INVERT : step -> p_step - | P_STEP : step -> p_step - | P_NOP : p_step. - -(* List of normalizations to perform : with a constructor of type - [p_step] allowing to visit both left and right branches, we would be - able to restrict to only one normalization by hypothesis. - And since all hypothesis are useful (otherwise they wouldn't be included), - we would be able to replace [h_step] by a simple list. *) - -Inductive h_step : Set := - pair_step : nat -> p_step -> h_step. - -(* \subsubsection{Rules for decomposing the hypothesis} *) -(* This type allows to navigate in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a - conjonction with possibly the right level of negations. *) - -Inductive direction : Set := - | D_left : direction - | D_right : direction - | D_mono : direction. - -(* This type allows to extract useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system - via the use of the trace type of Omega [t_omega] *) - -Inductive e_step : Set := - | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> list direction -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(* \subsection{Efficient decidable equality} *) -(* For each reified data-type, we define an efficient equality test. - It is not the one produced by [Decide Equality]. - - Then we prove two theorem allowing to eliminate such equalities : - \begin{verbatim} - (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. - (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. - \end{verbatim} *) - -(* \subsubsection{Reified terms} *) - -Open Scope romega_scope. - -Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := - match t1, t2 with - | Tint st1, Tint st2 => beq st1 st2 - | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 - | (- st1), (- st2) => eq_term st1 st2 - | [st1], [st2] => beq_nat st1 st2 - | _, _ => false - end. - -Close Scope romega_scope. - -Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. -Proof. - simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); - [ intros; elim beq_true with (1 := H); trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 H3; elim H with (1 := H3); trivial - | intros; elim beq_nat_true with (1 := H); trivial ]. -Qed. - -Ltac trivial_case := unfold not in |- *; intros; discriminate. - -Theorem eq_term_false : - forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. -Proof. - simple induction t1; - [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_false with (1 := H); simplify_eq H0; - auto - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; - unfold not in |- *; intro H4; elim H1 with (1 := H3); - simplify_eq H4; auto - | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_nat_false with (1 := H); simplify_eq H0; - auto ]. -Qed. - -(* \subsubsection{Tactiques pour éliminer ces tests} - - Si on se contente de faire un [Case (eq_typ t1 t2)] on perd - totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. - - Initialement, les développements avaient été réalisés avec les - tests rendus par [Decide Equality], c'est à dire un test rendant - des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un - tel test préserve bien l'information voulue mais calculatoirement de - telles fonctions sont trop lentes. *) - -(* Les tactiques définies si après se comportent exactement comme si on - avait utilisé le test précédent et fait une elimination dessus. *) - -Ltac elim_eq_term t1 t2 := - pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux; - [ generalize (eq_term_true t1 t2 Aux); clear Aux - | generalize (eq_term_false t1 t2 Aux); clear Aux ]. - -Ltac elim_beq t1 t2 := - pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux; - [ generalize (beq_true t1 t2 Aux); clear Aux - | generalize (beq_false t1 t2 Aux); clear Aux ]. - -Ltac elim_bgt t1 t2 := - pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; - [ generalize (bgt_true t1 t2 Aux); clear Aux - | generalize (bgt_false t1 t2 Aux); clear Aux ]. - - -(* \subsection{Interprétations} - \subsubsection{Interprétation des termes dans Z} *) - -Fixpoint interp_term (env : list int) (t : term) {struct t} : int := - match t with - | Tint x => x - | (t1 + t2)%term => interp_term env t1 + interp_term env t2 - | (t1 * t2)%term => interp_term env t1 * interp_term env t2 - | (t1 - t2)%term => interp_term env t1 - interp_term env t2 - | (- t)%term => - interp_term env t - | [n]%term => nth n env 0 - end. - -(* \subsubsection{Interprétation des prédicats} *) - -Fixpoint interp_proposition (envp : list Prop) (env : list int) - (p : proposition) {struct p} : Prop := - match p with - | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 - | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 - | TrueTerm => True - | FalseTerm => False - | Tnot p' => ~ interp_proposition envp env p' - | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 - | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 - | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) - | Tor p1 p2 => - interp_proposition envp env p1 \/ interp_proposition envp env p2 - | Tand p1 p2 => - interp_proposition envp env p1 /\ interp_proposition envp env p2 - | Timp p1 p2 => - interp_proposition envp env p1 -> interp_proposition envp env p2 - | Tprop n => nth n envp True - end. - -(* \subsubsection{Inteprétation des listes d'hypothèses} - \paragraph{Sous forme de conjonction} - Interprétation sous forme d'une conjonction d'hypothèses plus faciles - à manipuler individuellement *) - -Fixpoint interp_hyps (envp : list Prop) (env : list int) - (l : hyps) {struct l} : Prop := - match l with - | nil => True - | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' - end. - -(* \paragraph{sous forme de but} - C'est cette interpétation que l'on utilise sur le but (car on utilise - [Generalize] et qu'une conjonction est forcément lourde (répétition des - types dans les conjonctions intermédiaires) *) - -Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) - (env : list int) (l : hyps) {struct l} : Prop := - match l with - | nil => interp_proposition envp env c - | p' :: l' => - interp_proposition envp env p' -> interp_goal_concl c envp env l' - end. - -Notation interp_goal := (interp_goal_concl FalseTerm). - -(* Les théorèmes qui suivent assurent la correspondance entre les deux - interprétations. *) - -Theorem goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : hyps), - (interp_hyps envp env l -> False) -> interp_goal envp env l. -Proof. - simple induction l; - [ simpl in |- *; auto - | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. -Qed. - -Theorem hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : hyps), - interp_goal envp env l -> interp_hyps envp env l -> False. -Proof. - simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. -Qed. - -(* \subsection{Manipulations sur les hypothèses} *) - -(* \subsubsection{Définitions de base de stabilité pour la réflexion} *) -(* Une opération laisse un terme stable si l'égalité est préservée *) -Definition term_stable (f : term -> term) := - forall (e : list int) (t : term), interp_term e t = interp_term e (f t). - -(* Une opération est valide sur une hypothèse, si l'hypothèse implique le - résultat de l'opération. \emph{Attention : cela ne concerne que des - opérations sur les hypothèses et non sur les buts (contravariance)}. - On définit la validité pour une opération prenant une ou deux propositions - en argument (cela suffit pour omega). *) - -Definition valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e p1 -> interp_proposition ep e (f p1). - -Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 p2 : proposition), - interp_proposition ep e p1 -> - interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). - -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. - On reste contravariant *) - -Definition valid_hyps (f : hyps -> hyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_hyps ep e (f lp). - -(* Enfin ce théorème élimine la contravariance et nous ramène à une - opération sur les buts *) - -Theorem valid_goal : - forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), - valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. -Proof. - intros; simpl in |- *; apply goal_to_hyps; intro H1; - apply (hyps_to_goal ep env (a l) H0); apply H; assumption. -Qed. - -(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) - - -Fixpoint interp_list_hyps (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := - match l with - | nil => False - | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' - end. - -Fixpoint interp_list_goal (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := - match l with - | nil => True - | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' - end. - -Theorem list_goal_to_hyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. -Proof. - simple induction l; simpl in |- *; - [ auto - | intros h1 l1 H H1; split; - [ apply goal_to_hyps; intro H2; apply H1; auto - | apply H; intro H2; apply H1; auto ] ]. -Qed. - -Theorem list_hyps_to_goal : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env l -> interp_list_hyps envp env l -> False. -Proof. - simple induction l; simpl in |- *; - [ auto - | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; - [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. -Qed. - -Definition valid_list_hyps (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Definition valid_list_goal (f : hyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_list_goal ep e (f lp) -> interp_goal ep e lp. - -Theorem goal_valid : - forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. -Proof. - unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; - intro H2; apply list_hyps_to_goal with (1 := H1); - apply (H ep e lp); assumption. -Qed. - -Theorem append_valid : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> - interp_list_hyps ep e (l1 ++ l2). -Proof. - intros ep e; simple induction l1; - [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ] - | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H]; - [ auto - | right; apply (HR l2); left; trivial - | right; apply (HR l2); right; trivial ] ]. - -Qed. - -(* \subsubsection{Opérateurs valides sur les hypothèses} *) - -(* Extraire une hypothèse de la liste *) -Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. - -Theorem nth_valid : - forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), - interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). -Proof. - unfold nth_hyps in |- *; simple induction i; - [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ] - | intros n H; simple induction l; - [ simpl in |- *; trivial - | intros; simpl in |- *; apply H; elim H1; auto ] ]. -Qed. - -(* Appliquer une opération (valide) sur deux hypothèses extraites de - la liste et ajouter le résultat à la liste. *) -Definition apply_oper_2 (i j : nat) - (f : proposition -> proposition -> proposition) (l : hyps) := - f (nth_hyps i l) (nth_hyps j l) :: l. - -Theorem apply_oper_2_valid : - forall (i j : nat) (f : proposition -> proposition -> proposition), - valid2 f -> valid_hyps (apply_oper_2 i j f). -Proof. - intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; - intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. -Qed. - -(* Modifier une hypothèse par application d'une opération valide *) - -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) - (l : hyps) {struct i} : hyps := - match l with - | nil => nil (A:=proposition) - | p :: l' => - match i with - | O => f p :: l' - | S j => p :: apply_oper_1 j f l' - end - end. - -Theorem apply_oper_1_valid : - forall (i : nat) (f : proposition -> proposition), - valid1 f -> valid_hyps (apply_oper_1 i f). -Proof. - unfold valid_hyps in |- *; intros i f Hf ep e; elim i; - [ intro lp; case lp; - [ simpl in |- *; trivial - | simpl in |- *; intros p l' (H1, H2); split; - [ apply Hf with (1 := H1) | assumption ] ] - | intros n Hrec lp; case lp; - [ simpl in |- *; auto - | simpl in |- *; intros p l' (H1, H2); split; - [ assumption | apply Hrec; assumption ] ] ]. -Qed. - -(* \subsubsection{Manipulations de termes} *) -(* Les fonctions suivantes permettent d'appliquer une fonction de - réécriture sur un sous terme du terme principal. Avec la composition, - cela permet de construire des réécritures complexes proches des - tactiques de conversion *) - -Definition apply_left (f : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + y)%term - | (x * y)%term => (f x * y)%term - | (- x)%term => (- f x)%term - | x => x - end. - -Definition apply_right (f : term -> term) (t : term) := - match t with - | (x + y)%term => (x + f y)%term - | (x * y)%term => (x * f y)%term - | x => x - end. - -Definition apply_both (f g : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + g y)%term - | (x * y)%term => (f x * g y)%term - | x => x - end. - -(* Les théorèmes suivants montrent la stabilité (conditionnée) des - fonctions. *) - -Theorem apply_left_stable : - forall f : term -> term, term_stable f -> term_stable (apply_left f). -Proof. - unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; - intros; elim H; trivial. -Qed. - -Theorem apply_right_stable : - forall f : term -> term, term_stable f -> term_stable (apply_right f). -Proof. - unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; - intros t0 t1; elim H; trivial. -Qed. - -Theorem apply_both_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (apply_both f g). -Proof. - unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; - intros t0 t1; elim H1; elim H2; trivial. -Qed. - -Theorem compose_term_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). -Proof. - unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. -Qed. - -(* \subsection{Les règles de réécriture} *) -(* Chacune des règles de réécriture est accompagnée par sa preuve de - stabilité. Toutes ces preuves ont la même forme : il faut analyser - suivant la forme du terme (élimination de chaque Case). On a besoin d'une - élimination uniquement dans les cas d'utilisation d'égalité décidable. - - Cette tactique itère la décomposition des Case. Elle est - constituée de deux fonctions s'appelant mutuellement : - \begin{itemize} - \item une fonction d'enrobage qui lance la recherche sur le but, - \item une fonction récursive qui décompose ce but. Quand elle a trouvé un - Case, elle l'élimine. - \end{itemize} - Les motifs sur les cas sont très imparfaits et dans certains cas, il - semble que cela ne marche pas. On aimerait plutot un motif de la - forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on - utilise le bon type. - - Chaque élimination introduit correctement exactement le nombre d'hypothèses - nécessaires et conserve dans le cas d'une égalité la connaissance du - résultat du test en faisant la réécriture. Pour un test de comparaison, - on conserve simplement le résultat. - - Cette fonction déborde très largement la résolution des réécritures - simples et fait une bonne partie des preuves des pas de Omega. -*) - -(* \subsubsection{La tactique pour prouver la stabilité} *) - -Ltac loop t := - match t with - (* Global *) - | (?X1 = ?X2) => loop X1 || loop X2 - | (_ -> ?X1) => loop X1 - (* Interpretations *) - | (interp_hyps _ _ ?X1) => loop X1 - | (interp_list_hyps _ _ ?X1) => loop X1 - | (interp_proposition _ _ ?X1) => loop X1 - | (interp_term _ ?X1) => loop X1 - (* Propositions *) - | (EqTerm ?X1 ?X2) => loop X1 || loop X2 - | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - (* Termes *) - | (?X1 + ?X2)%term => loop X1 || loop X2 - | (?X1 - ?X2)%term => loop X1 || loop X2 - | (?X1 * ?X2)%term => loop X1 || loop X2 - | (- ?X1)%term => loop X1 - | (Tint ?X1) => loop X1 - (* Eliminations *) - | match ?X1 with - | EqTerm x x0 => _ - | LeqTerm x x0 => _ - | TrueTerm => _ - | FalseTerm => _ - | Tnot x => _ - | GeqTerm x x0 => _ - | GtTerm x x0 => _ - | LtTerm x x0 => _ - | NeqTerm x x0 => _ - | Tor x x0 => _ - | Tand x x0 => _ - | Timp x x0 => _ - | Tprop x => _ - end => destruct X1; auto; Simplify - | match ?X1 with - | Tint x => _ - | (x + x0)%term => _ - | (x * x0)%term => _ - | (x - x0)%term => _ - | (- x)%term => _ - | [x]%term => _ - end => destruct X1; auto; Simplify - | (if beq ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_beq X1 X2; intro H; try (rewrite H in *; clear H); - simpl in |- *; auto; Simplify - | (if bgt ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify - | (if eq_term ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); - simpl in |- *; auto; Simplify - | (if _ && _ then _ else _) => rewrite andb_if; Simplify - | (if negb _ then _ else _) => rewrite negb_if; Simplify - | _ => fail - end - -with Simplify := match goal with - | |- ?X1 => try loop X1 - | _ => idtac - end. - -Ltac prove_stable x th := - match constr:x with - | ?X1 => - unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *; - apply th - end. - -(* \subsubsection{Les règles elle mêmes} *) -Definition Tplus_assoc_l (t : term) := - match t with - | (n + (m + p))%term => (n + m + p)%term - | _ => t - end. - -Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. -Proof. - prove_stable Tplus_assoc_l (ring.(Radd_assoc)). -Qed. - -Definition Tplus_assoc_r (t : term) := - match t with - | (n + m + p)%term => (n + (m + p))%term - | _ => t - end. - -Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. -Proof. - prove_stable Tplus_assoc_r plus_assoc_reverse. -Qed. - -Definition Tmult_assoc_r (t : term) := - match t with - | (n * m * p)%term => (n * (m * p))%term - | _ => t - end. - -Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. -Proof. - prove_stable Tmult_assoc_r mult_assoc_reverse. -Qed. - -Definition Tplus_permute (t : term) := - match t with - | (n + (m + p))%term => (m + (n + p))%term - | _ => t - end. - -Theorem Tplus_permute_stable : term_stable Tplus_permute. -Proof. - prove_stable Tplus_permute plus_permute. -Qed. - -Definition Tplus_comm (t : term) := - match t with - | (x + y)%term => (y + x)%term - | _ => t - end. - -Theorem Tplus_comm_stable : term_stable Tplus_comm. -Proof. - prove_stable Tplus_comm plus_comm. -Qed. - -Definition Tmult_comm (t : term) := - match t with - | (x * y)%term => (y * x)%term - | _ => t - end. - -Theorem Tmult_comm_stable : term_stable Tmult_comm. -Proof. - prove_stable Tmult_comm mult_comm. -Qed. - -Definition T_OMEGA10 (t : term) := - match t with - | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA10_stable : term_stable T_OMEGA10. -Proof. - prove_stable T_OMEGA10 OMEGA10. -Qed. - -Definition T_OMEGA11 (t : term) := - match t with - | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => - (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term - | _ => t - end. - -Theorem T_OMEGA11_stable : term_stable T_OMEGA11. -Proof. - prove_stable T_OMEGA11 OMEGA11. -Qed. - -Definition T_OMEGA12 (t : term) := - match t with - | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => - (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term - | _ => t - end. - -Theorem T_OMEGA12_stable : term_stable T_OMEGA12. -Proof. - prove_stable T_OMEGA12 OMEGA12. -Qed. - -Definition T_OMEGA13 (t : term) := - match t with - | (v * Tint x + l1 + (v' * Tint x' + l2))%term => - if eq_term v v' && beq x (-x') - then (l1+l2)%term - else t - | _ => t - end. - -Theorem T_OMEGA13_stable : term_stable T_OMEGA13. -Proof. - unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; - apply OMEGA13. -Qed. - -Definition T_OMEGA15 (t : term) := - match t with - | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA15_stable : term_stable T_OMEGA15. -Proof. - prove_stable T_OMEGA15 OMEGA15. -Qed. - -Definition T_OMEGA16 (t : term) := - match t with - | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term - | _ => t - end. - - -Theorem T_OMEGA16_stable : term_stable T_OMEGA16. -Proof. - prove_stable T_OMEGA16 OMEGA16. -Qed. - -Definition Tred_factor5 (t : term) := - match t with - | (x * Tint c + y)%term => if beq c 0 then y else t - | _ => t - end. - -Theorem Tred_factor5_stable : term_stable Tred_factor5. -Proof. - prove_stable Tred_factor5 red_factor5. -Qed. - -Definition Topp_plus (t : term) := - match t with - | (- (x + y))%term => (- x + - y)%term - | _ => t - end. - -Theorem Topp_plus_stable : term_stable Topp_plus. -Proof. - prove_stable Topp_plus opp_plus_distr. -Qed. - - -Definition Topp_opp (t : term) := - match t with - | (- - x)%term => x - | _ => t - end. - -Theorem Topp_opp_stable : term_stable Topp_opp. -Proof. - prove_stable Topp_opp opp_involutive. -Qed. - -Definition Topp_mult_r (t : term) := - match t with - | (- (x * Tint k))%term => (x * Tint (- k))%term - | _ => t - end. - -Theorem Topp_mult_r_stable : term_stable Topp_mult_r. -Proof. - prove_stable Topp_mult_r opp_mult_distr_r. -Qed. - -Definition Topp_one (t : term) := - match t with - | (- x)%term => (x * Tint (-(1)))%term - | _ => t - end. - -Theorem Topp_one_stable : term_stable Topp_one. -Proof. - prove_stable Topp_one opp_eq_mult_neg_1. -Qed. - -Definition Tmult_plus_distr (t : term) := - match t with - | ((n + m) * p)%term => (n * p + m * p)%term - | _ => t - end. - -Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. -Proof. - prove_stable Tmult_plus_distr mult_plus_distr_r. -Qed. - -Definition Tmult_opp_left (t : term) := - match t with - | (- x * Tint y)%term => (x * Tint (- y))%term - | _ => t - end. - -Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. -Proof. - prove_stable Tmult_opp_left mult_opp_comm. -Qed. - -Definition Tmult_assoc_reduced (t : term) := - match t with - | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term - | _ => t - end. - -Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. -Proof. - prove_stable Tmult_assoc_reduced mult_assoc_reverse. -Qed. - -Definition Tred_factor0 (t : term) := (t * Tint 1)%term. - -Theorem Tred_factor0_stable : term_stable Tred_factor0. -Proof. - prove_stable Tred_factor0 red_factor0. -Qed. - -Definition Tred_factor1 (t : term) := - match t with - | (x + y)%term => - if eq_term x y - then (x * Tint 2)%term - else t - | _ => t - end. - -Theorem Tred_factor1_stable : term_stable Tred_factor1. -Proof. - prove_stable Tred_factor1 red_factor1. -Qed. - -Definition Tred_factor2 (t : term) := - match t with - | (x + y * Tint k)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. - -Theorem Tred_factor2_stable : term_stable Tred_factor2. -Proof. - prove_stable Tred_factor2 red_factor2. -Qed. - -Definition Tred_factor3 (t : term) := - match t with - | (x * Tint k + y)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. - -Theorem Tred_factor3_stable : term_stable Tred_factor3. -Proof. - prove_stable Tred_factor3 red_factor3. -Qed. - - -Definition Tred_factor4 (t : term) := - match t with - | (x * Tint k1 + y * Tint k2)%term => - if eq_term x y - then (x * Tint (k1 + k2))%term - else t - | _ => t - end. - -Theorem Tred_factor4_stable : term_stable Tred_factor4. -Proof. - prove_stable Tred_factor4 red_factor4. -Qed. - -Definition Tred_factor6 (t : term) := (t + Tint 0)%term. - -Theorem Tred_factor6_stable : term_stable Tred_factor6. -Proof. - prove_stable Tred_factor6 red_factor6. -Qed. - -Definition Tminus_def (t : term) := - match t with - | (x - y)%term => (x + - y)%term - | _ => t - end. - -Theorem Tminus_def_stable : term_stable Tminus_def. -Proof. - prove_stable Tminus_def minus_def. -Qed. - -(* \subsection{Fonctions de réécriture complexes} *) - -(* \subsubsection{Fonction de réduction} *) -(* Cette fonction réduit un terme dont la forme normale est un entier. Il - suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs - réifiés. La réduction est ``gratuite''. *) - -Fixpoint reduce (t : term) : term := - match t with - | (x + y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' + y') - | y' => (Tint x' + y')%term - end - | x' => (x' + reduce y)%term - end - | (x * y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' * y') - | y' => (Tint x' * y')%term - end - | x' => (x' * reduce y)%term - end - | (x - y)%term => - match reduce x with - | Tint x' => - match reduce y with - | Tint y' => Tint (x' - y') - | y' => (Tint x' - y')%term - end - | x' => (x' - reduce y)%term - end - | (- x)%term => - match reduce x with - | Tint x' => Tint (- x') - | x' => (- x')%term - end - | _ => t - end. - -Theorem reduce_stable : term_stable reduce. -Proof. - unfold term_stable in |- *; intros e t; elim t; auto; - try - (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1; - (case (reduce t0); - [ intro z0; case (reduce t1); intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto ])); intros t0 H0; simpl in |- *; - rewrite H0; case (reduce t0); intros; auto. -Qed. - -(* \subsubsection{Fusions} - \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. - Cette fonction prend une trace de fusion en argument et transforme - le terme en une équation normalisée. C'est une version très simplifiée - du moteur de réécriture [rewrite]. *) - -Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := - match trace with - | nil => reduce t - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA10 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) - | F_left => apply_right (fusion trace') (T_OMEGA11 t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end - end. - -Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). -Proof. - simple induction t; simpl in |- *; - [ exact reduce_stable - | intros stp l H; case stp; - [ apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] - | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable; - rewrite Tred_factor5_stable; apply H - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. -Qed. - -(* \paragraph{Fusion de deux équations dont une sans coefficient} *) - -Definition fusion_right (trace : list t_fusion) (t : term) : term := - match trace with - | nil => reduce t (* Il faut mettre un compute *) - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA15 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) - | F_left => apply_right (fusion trace') (Tplus_assoc_r t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end - end. - -(* \paragraph{Fusion avec annihilation} *) -(* Normalement le résultat est une constante *) - -Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => fusion_cancel trace' (T_OMEGA13 t) - end. - -Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). -Proof. - unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; - [ exact (reduce_stable e) - | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. -Qed. - -(* \subsubsection{Opérations affines sur une équation} *) -(* \paragraph{Multiplication scalaire et somme d'une constante} *) - -Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) - end. - -Theorem scalar_norm_add_stable : - forall t : nat, term_stable (scalar_norm_add t). -Proof. - unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA11_stable e t) | exact H ] ]. -Qed. - -(* \paragraph{Multiplication scalaire} *) -Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) - end. - -Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). -Proof. - unfold term_stable, scalar_norm in |- *; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA16_stable e t) | exact H ] ]. -Qed. - -(* \paragraph{Somme d'une constante} *) -Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) - end. - -Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). -Proof. - unfold term_stable, add_norm in |- *; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. -Qed. - -(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) - - -Fixpoint rewrite (s : step) : term -> term := - match s with - | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2) - | C_LEFT s => apply_left (rewrite s) - | C_RIGHT s => apply_right (rewrite s) - | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t) - | C_NOP => fun t : term => t - | C_OPP_PLUS => Topp_plus - | C_OPP_OPP => Topp_opp - | C_OPP_MULT_R => Topp_mult_r - | C_OPP_ONE => Topp_one - | C_REDUCE => reduce - | C_MULT_PLUS_DISTR => Tmult_plus_distr - | C_MULT_OPP_LEFT => Tmult_opp_left - | C_MULT_ASSOC_R => Tmult_assoc_r - | C_PLUS_ASSOC_R => Tplus_assoc_r - | C_PLUS_ASSOC_L => Tplus_assoc_l - | C_PLUS_PERMUTE => Tplus_permute - | C_PLUS_COMM => Tplus_comm - | C_RED0 => Tred_factor0 - | C_RED1 => Tred_factor1 - | C_RED2 => Tred_factor2 - | C_RED3 => Tred_factor3 - | C_RED4 => Tred_factor4 - | C_RED5 => Tred_factor5 - | C_RED6 => Tred_factor6 - | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced - | C_MINUS => Tminus_def - | C_MULT_COMM => Tmult_comm - end. - -Theorem rewrite_stable : forall s : step, term_stable (rewrite s). -Proof. - simple induction s; simpl in |- *; - [ intros; apply apply_both_stable; auto - | intros; apply apply_left_stable; auto - | intros; apply apply_right_stable; auto - | unfold term_stable in |- *; intros; elim H0; apply H - | unfold term_stable in |- *; auto - | exact Topp_plus_stable - | exact Topp_opp_stable - | exact Topp_mult_r_stable - | exact Topp_one_stable - | exact reduce_stable - | exact Tmult_plus_distr_stable - | exact Tmult_opp_left_stable - | exact Tmult_assoc_r_stable - | exact Tplus_assoc_r_stable - | exact Tplus_assoc_l_stable - | exact Tplus_permute_stable - | exact Tplus_comm_stable - | exact Tred_factor0_stable - | exact Tred_factor1_stable - | exact Tred_factor2_stable - | exact Tred_factor3_stable - | exact Tred_factor4_stable - | exact Tred_factor5_stable - | exact Tred_factor6_stable - | exact Tmult_assoc_reduced_stable - | exact Tminus_def_stable - | exact Tmult_comm_stable ]. -Qed. - -(* \subsection{tactiques de résolution d'un but omega normalisé} - Trace de la procédure -\subsubsection{Tactiques générant une contradiction} -\paragraph{[O_CONSTANT_NOT_NUL]} *) - -Definition constant_not_nul (i : nat) (h : hyps) := - match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => - if beq n Nul then h else absurd - | _ => h - end. - -Theorem constant_not_nul_valid : - forall i : nat, valid_hyps (constant_not_nul i). -Proof. - unfold valid_hyps, constant_not_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *. - - elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; - elim H1; symmetry in |- *; auto. -Qed. - -(* \paragraph{[O_CONSTANT_NEG]} *) - -Definition constant_neg (i : nat) (h : hyps) := - match nth_hyps i h with - | LeqTerm (Tint Nul) (Tint Neg) => - if bgt Nul Neg then absurd else h - | _ => h - end. - -Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). -Proof. - unfold valid_hyps, constant_neg in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. -Qed. - -(* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : int) (body : term) - (t i : nat) (l : hyps) := - match nth_hyps i l with - | EqTerm (Tint Nul) b => - if beq Nul 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k2 0 && - bgt k1 k2 - then absurd - else l - | _ => l - end. - -Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t i : nat), - valid_hyps (not_exact_divide k1 k2 body t i). -Proof. - unfold valid_hyps, not_exact_divide in |- *; intros; - generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t e), <-H1. - do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. - absurd (interp_term e body * k1 + k2 = 0); - [ now apply OMEGA4 | symmetry; auto ]. -Qed. - -(* \paragraph{[O_CONTRADICTION]} *) - -Definition contradiction (t i j : nat) (l : hyps) := - match nth_hyps i l with - | LeqTerm (Tint Nul) b1 => - match nth_hyps j l with - | LeqTerm (Tint Nul') b2 => - match fusion_cancel t (b1 + b2)%term with - | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k - then absurd - else l - | _ => l - end - | _ => l - end - | _ => l - end. - -Theorem contradiction_valid : - forall t i j : nat, valid_hyps (contradiction t i j). -Proof. - unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; - simpl in |- *; intros z z' H1 H2; - generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term))); - pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *; - case (fusion_cancel t (t2 + t4)%term); simpl in |- *; - auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. - Simplify; intro H3. - generalize (OMEGA2 _ _ H2 H1); rewrite H3. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. -Qed. - -(* \paragraph{[O_NEGATE_CONTRADICT]} *) - -Definition negate_contradict (i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | _ => h - end. - -Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) - then absurd - else h - | _ => h - end - | _ => h - end. - -Theorem negate_contradict_valid : - forall i j : nat, valid_hyps (negate_contradict i j). -Proof. - unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify. -Qed. - -Theorem negate_contradict_inv_valid : - forall t i j : nat, valid_hyps (negate_contradict_inv t i j). -Proof. - unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify; - [ - rewrite <- scalar_norm_stable in H2; simpl in *; - elim (mult_integral (interp_term e t4) (-(1))); intuition; - elim minus_one_neq_zero; auto - | - elim H2; clear H2; - rewrite <- scalar_norm_stable; simpl in *; - now rewrite <- H1, mult_0_l - ]. -Qed. - -(* \subsubsection{Tactiques générant une nouvelle équation} *) -(* \paragraph{[O_SUM]} - C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant - les opérateurs de comparaison des deux arguments) d'où une - preuve un peu compliquée. On utilise quelques lemmes qui sont des - généralisations des théorèmes utilisés par OMEGA. *) - -Definition sum (k1 k2 : int) (trace : list t_fusion) - (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint Null) b1 => - match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm - | _ => TrueTerm - end - | LeqTerm (Tint Null) b1 => - if beq Null 0 && bgt k1 0 - then match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null' 0 then - LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm - | _ => TrueTerm - end - else TrueTerm - | NeqTerm (Tint Null) b1 => - match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) - then NeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - - -Theorem sum_valid : - forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). -Proof. - unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; - Simplify; simpl in |- *; auto; try elim (fusion_stable t); - simpl in |- *; intros; - [ apply sum1; assumption - | apply sum2; try assumption; apply sum4; assumption - | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption - | apply sum3; try assumption; apply sum4; assumption - | apply sum5; auto ]. -Qed. - -(* \paragraph{[O_EXACT_DIVIDE]} - c'est une oper1 valide mais on préfère une substitution a ce point la *) - -Definition exact_divide (k : int) (body : term) (t : nat) - (prop : proposition) := - match prop with - | EqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) - then EqTerm (Tint 0) body - else TrueTerm - | NeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) - then NeqTerm (Tint 0) body - else TrueTerm - | _ => TrueTerm - end. - -Theorem exact_divide_valid : - forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). -Proof. - unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; - Simplify; simpl; auto; subst; - rewrite <- scalar_norm_stable; simpl; intros; - [ destruct (mult_integral _ _ (sym_eq H0)); intuition - | contradict H0; rewrite <- H0, mult_0_l; auto - ]. -Qed. - - -(* \paragraph{[O_DIV_APPROX]} - La preuve reprend le schéma de la précédente mais on - est sur une opération de type valid1 et non sur une opération terminale. *) - -Definition divide_and_approx (k1 k2 : int) (body : term) - (t : nat) (prop : proposition) := - match prop with - | LeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k1 0 && - bgt k1 k2 - then LeqTerm (Tint 0) body - else prop - | _ => prop - end. - -Theorem divide_and_approx_valid : - forall (k1 k2 : int) (body : term) (t : nat), - valid1 (divide_and_approx k1 k2 body t). -Proof. - unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; - Simplify; simpl; auto; subst; - elim (scalar_norm_add_stable t e); simpl in |- *. - intro H2; apply mult_le_approx with (3 := H2); assumption. -Qed. - -(* \paragraph{[MERGE_EQ]} *) - -Definition merge_eq (t : nat) (prop1 prop2 : proposition) := - match prop1 with - | LeqTerm (Tint Null) b1 => - match prop2 with - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) - then EqTerm (Tint 0) b1 - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). -Proof. - unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; - auto; elim (scalar_norm_stable n e); simpl in |- *; - intros; symmetry in |- *; apply OMEGA8 with (2 := H0); - [ assumption | elim opp_eq_mult_neg_1; trivial ]. -Qed. - - - -(* \paragraph{[O_CONSTANT_NUL]} *) - -Definition constant_nul (i : nat) (h : hyps) := - match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h - | _ => h - end. - -Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). -Proof. - unfold valid_hyps, constant_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - intro H1; absurd (0 = 0); intuition. -Qed. - -(* \paragraph{[O_STATE]} *) - -Definition state (m : int) (s : step) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint Null) b1 => - match prop2 with - | EqTerm b2 b3 => - if beq Null 0 - then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). -Proof. - unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; - simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; - intros H1 H2; elim H1. - now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. -Qed. - -(* \subsubsection{Tactiques générant plusieurs but} - \paragraph{[O_SPLIT_INEQ]} - La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) - -Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) - (l : hyps) := - match nth_hyps i l with - | NeqTerm (Tint Null) b1 => - if beq Null 0 then - f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ - f2 - (LeqTerm (Tint 0) - (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) - else l :: nil - | _ => l :: nil - end. - -Theorem split_ineq_valid : - forall (i t : nat) (f1 f2 : hyps -> lhyps), - valid_list_hyps f1 -> - valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). -Proof. - unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; - generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); - simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; - auto; intros z; simpl in |- *; auto; intro H3. - Simplify. - apply append_valid; elim (OMEGA19 (interp_term e t2)); - [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t); - simpl in |- *; auto - | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t); - simpl in |- *; auto - | generalize H3; unfold not in |- *; intros E1 E2; apply E1; - symmetry in |- *; trivial ]. -Qed. - - -(* \subsection{La fonction de rejeu de la trace} *) - -Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := - match t with - | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) - | O_CONSTANT_NEG n => singleton (constant_neg n l) - | O_DIV_APPROX k1 k2 body t cont n => - execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) - | O_NOT_EXACT_DIVIDE k1 k2 body t i => - singleton (not_exact_divide k1 k2 body t i l) - | O_EXACT_DIVIDE k body t cont n => - execute_omega cont (apply_oper_1 n (exact_divide k body t) l) - | O_SUM k1 i1 k2 i2 t cont => - execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) - | O_CONTRADICTION t i j => singleton (contradiction t i j l) - | O_MERGE_EQ t i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) - | O_SPLIT_INEQ t i cont1 cont2 => - split_ineq i t (execute_omega cont1) (execute_omega cont2) l - | O_CONSTANT_NUL i => singleton (constant_nul i l) - | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) - | O_NEGATE_CONTRADICT_INV t i j => - singleton (negate_contradict_inv t i j l) - | O_STATE m s i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (state m s) l) - end. - -Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). -Proof. - simple induction t; simpl in |- *; - [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (constant_not_nul_valid n ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (constant_neg_valid n ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; - intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (divide_and_approx k1 k2 body n) - (divide_and_approx_valid k1 k2 body n) ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; - intros k body n t' Ht' m ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (exact_divide k body n) - (exact_divide_valid k body n) ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; - intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e - lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (contradiction_valid n n0 n1 ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; - intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e - lp H) - | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *; - intros ep e lp H; - apply - (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e - lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left; - apply (constant_nul_valid i ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left; - apply (negate_contradict_valid i j ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H; - left; apply (negate_contradict_inv_valid n i j ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; - intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; - apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. -Qed. - - -(* \subsection{Les opérations globales sur le but} - \subsubsection{Normalisation} *) - -Definition move_right (s : step) (p : proposition) := - match p with - | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term) - | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term) - | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term) - | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | p => p - end. - -Theorem move_right_valid : forall s : step, valid1 (move_right s). -Proof. - unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; - elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ]. -Qed. - -Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). - -Theorem do_normalize_valid : - forall (i : nat) (s : step), valid_hyps (do_normalize i s). -Proof. - intros; unfold do_normalize in |- *; apply apply_oper_1_valid; - apply move_right_valid. -Qed. - -Fixpoint do_normalize_list (l : list step) (i : nat) - (h : hyps) {struct l} : hyps := - match l with - | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) - | nil => h - end. - -Theorem do_normalize_list_valid : - forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). -Proof. - simple induction l; simpl in |- *; unfold valid_hyps in |- *; - [ auto - | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; - apply (do_normalize_valid i a ep e lp); assumption ]. -Qed. - -Theorem normalize_goal : - forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. -Qed. - -(* \subsubsection{Exécution de la trace} *) - -Theorem execute_goal : - forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. -Proof. - intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). -Qed. - - -Theorem append_goal : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> - interp_list_goal ep e (l1 ++ l2). -Proof. - intros ep e; simple induction l1; - [ simpl in |- *; intros l2 (H1, H2); assumption - | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. -Qed. - -(* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by - induction and uses well known theorem about arithmetic and propositional - calculus *) - -Fixpoint decidability (p : proposition) : bool := - match p with - | EqTerm _ _ => true - | LeqTerm _ _ => true - | GeqTerm _ _ => true - | GtTerm _ _ => true - | LtTerm _ _ => true - | NeqTerm _ _ => true - | FalseTerm => true - | TrueTerm => true - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - end. - -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_proposition ep e p). -Proof. - simple induction p; simpl in |- *; intros; - [ apply dec_eq - | apply dec_le - | left; auto - | right; unfold not in |- *; auto - | apply dec_not; auto - | apply dec_ge - | apply dec_gt - | apply dec_lt - | apply dec_ne - | apply dec_or; elim andb_prop with (1 := H1); auto - | apply dec_and; elim andb_prop with (1 := H1); auto - | apply dec_imp; elim andb_prop with (1 := H1); auto - | discriminate H ]. -Qed. - -(* An interpretation function for a complete goal with an explicit - conclusion. We use an intermediate fixpoint. *) - -Fixpoint interp_full_goal (envp : list Prop) (env : list int) - (c : proposition) (l : hyps) {struct l} : Prop := - match l with - | nil => interp_proposition envp env c - | p' :: l' => - interp_proposition envp env p' -> interp_full_goal envp env c l' - end. - -Definition interp_full (ep : list Prop) (e : list int) - (lc : hyps * proposition) : Prop := - match lc with - | (l, c) => interp_full_goal ep e c l - end. - -(* Relates the interpretation of a complete goal with the interpretation - of its hypothesis and conclusion *) - -Theorem interp_full_false : - forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), - (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). -Proof. - simple induction l; unfold interp_full in |- *; simpl in |- *; - [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. -Qed. - -(* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the - conclusion (equivalent of replacing it with false) *) - -Definition to_contradict (lc : hyps * proposition) := - match lc with - | (l, c) => if decidability c then Tnot c :: l else l - end. - -(* The previous operation is valid in the sense that the new list of - hypothesis implies the original goal *) - -Theorem to_contradict_valid : - forall (ep : list Prop) (e : list int) (lc : hyps * proposition), - interp_goal ep e (to_contradict lc) -> interp_full ep e lc. -Proof. - intros ep e lc; case lc; intros l c; simpl in |- *; - pattern (decidability c) in |- *; apply bool_eq_ind; - [ simpl in |- *; intros H H1; apply interp_full_false; intros H2; - apply not_not; - [ apply decidable_correct; assumption - | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2); - auto ] - | intros H1 H2; apply interp_full_false; intro H3; - elim hyps_to_goal with (1 := H2); assumption ]. -Qed. - -(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list - of lists *) - -Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : - list (list A) := - match l with - | nil => nil - | l :: ll => (x :: l) :: map_cons A x ll - end. - -(* This function breaks up a list of hypothesis in a list of simpler - list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. - Note that : - - we need a way to drive the analysis as some hypotheis may not - require a split. - - this procedure must be perfectly mimicked by the ML part otherwise - hypothesis will get desynchronised and this will be a mess. - *) - -Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := - match nn with - | O => ll :: nil - | S n => - match ll with - | nil => nil :: nil - | Tor p1 p2 :: l => - destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) - | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) - | Timp p1 p2 :: l => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) - else map_cons _ (Timp p1 p2) (destructure_hyps n l) - | Tnot p :: l => - match p with - | Tnot p1 => - if decidability p1 - then destructure_hyps n (p1 :: l) - else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) - | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) - | Tand p1 p2 => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ - destructure_hyps n (Tnot p2 :: l) - else map_cons _ (Tnot p) (destructure_hyps n l) - | _ => map_cons _ (Tnot p) (destructure_hyps n l) - end - | x :: l => map_cons _ x (destructure_hyps n l) - end - end. - -Theorem map_cons_val : - forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), - interp_proposition ep e p -> - interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). -Proof. - simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. -Qed. - -Hint Resolve map_cons_val append_valid decidable_correct. - -Theorem destructure_hyps_valid : - forall n : nat, valid_list_hyps (destructure_hyps n). -Proof. - simple induction n; - [ unfold valid_list_hyps in |- *; simpl in |- *; auto - | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp; - [ simpl in |- *; auto - | intros p l; case p; - try - (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; - auto); - [ intro p'; case p'; - try - (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; - auto); - [ simpl in |- *; intros p1 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; - intro H3; - [ apply H; simpl in |- *; split; - [ apply not_not; auto | assumption ] - | auto ] - | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; - elim not_or with (1 := H1); auto - | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; - intro H3; - [ apply append_valid; elim not_and with (2 := H1); - [ intro; left; apply H; simpl in |- *; auto - | intro; right; apply H; simpl in |- *; auto - | auto ] - | auto ] ] - | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl in |- *; [ left | right ]); - apply H; simpl in |- *; auto - | simpl in |- *; intros; apply H; simpl in |- *; tauto - | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; - intro H3; - [ apply append_valid; elim imp_simp with (2 := H1); - [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto - | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto - | auto ] - | auto ] ] ] ]. -Qed. - -Definition prop_stable (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p : proposition), - interp_proposition ep e p <-> interp_proposition ep e (f p). - -Definition p_apply_left (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp (f x) y - | Tor x y => Tor (f x) y - | Tand x y => Tand (f x) y - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_left_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_left f). -Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto). -Qed. - -Definition p_apply_right (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp x (f y) - | Tor x y => Tor x (f y) - | Tand x y => Tand x (f y) - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_right_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_right f). -Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; - [ intros p1; elim (H ep e p1); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto ]). -Qed. - -Definition p_invert (f : proposition -> proposition) - (p : proposition) := - match p with - | EqTerm x y => Tnot (f (NeqTerm x y)) - | LeqTerm x y => Tnot (f (GtTerm x y)) - | GeqTerm x y => Tnot (f (LtTerm x y)) - | GtTerm x y => Tnot (f (LeqTerm x y)) - | LtTerm x y => Tnot (f (GeqTerm x y)) - | NeqTerm x y => Tnot (f (EqTerm x y)) - | x => x - end. - -Theorem p_invert_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_invert f). -Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; - [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; tauto - | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto - | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; repeat rewrite le_lt_iff; - repeat rewrite gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; repeat rewrite ge_le_iff; - repeat rewrite le_lt_iff; tauto - | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; tauto ]). -Qed. - -Theorem move_right_stable : forall s : step, prop_stable (move_right s). -Proof. - unfold move_right, prop_stable in |- *; intros s ep e p; split; - [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ] - | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); - simpl in |- *; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; - rewrite plus_permute; rewrite plus_opp_r; - rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); - rewrite plus_opp_r; assumption - | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); - rewrite plus_opp_r; assumption - | rewrite gt_lt_iff; apply lt_left_inv; assumption - | apply lt_left_inv; assumption - | unfold not in |- *; intro H2; apply H1; - rewrite H2; rewrite plus_opp_r; trivial ] ]. -Qed. - - -Fixpoint p_rewrite (s : p_step) : proposition -> proposition := - match s with - | P_LEFT s => p_apply_left (p_rewrite s) - | P_RIGHT s => p_apply_right (p_rewrite s) - | P_STEP s => move_right s - | P_INVERT s => p_invert (move_right s) - | P_NOP => fun p : proposition => p - end. - -Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). -Proof. - simple induction s; simpl in |- *; - [ intros; apply p_apply_left_stable; trivial - | intros; apply p_apply_right_stable; trivial - | intros; apply p_invert_stable; apply move_right_stable - | apply move_right_stable - | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ]. -Qed. - -Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := - match l with - | nil => lh - | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) - end. - -Theorem normalize_hyps_valid : - forall l : list h_step, valid_hyps (normalize_hyps l). -Proof. - simple induction l; unfold valid_hyps in |- *; simpl in |- *; - [ auto - | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; - apply apply_oper_1_valid; - [ unfold valid1 in |- *; intros ep1 e1 p1 H2; - elim (p_rewrite_stable s ep1 e1 p1); auto - | assumption ] ]. -Qed. - -Theorem normalize_hyps_goal : - forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. -Qed. - -Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : - proposition := - match s with - | D_left :: l => - match p with - | Tand x y => extract_hyp_pos l x - | _ => p - end - | D_right :: l => - match p with - | Tand x y => extract_hyp_pos l y - | _ => p - end - | D_mono :: l => match p with - | Tnot x => extract_hyp_neg l x - | _ => p - end - | _ => p - end - - with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : - proposition := - match s with - | D_left :: l => - match p with - | Tor x y => extract_hyp_neg l x - | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | D_right :: l => - match p with - | Tor x y => extract_hyp_neg l y - | Timp x y => extract_hyp_neg l y - | _ => Tnot p - end - | D_mono :: l => - match p with - | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | _ => - match p with - | Tnot x => if decidability x then x else Tnot p - | _ => Tnot p - end - end. - -Definition co_valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). - -Theorem extract_valid : - forall s : list direction, - valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). -Proof. - unfold valid1, co_valid1 in |- *; simple induction s; - [ split; - [ simpl in |- *; auto - | intros ep e p1; case p1; simpl in |- *; auto; intro p; - pattern (decidability p) in |- *; apply bool_eq_ind; - [ intro H; generalize (decidable_correct ep e p H); - unfold decidable in |- *; tauto - | simpl in |- *; auto ] ] - | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; - case p; auto; simpl in |- *; intros; - (apply H1; tauto) || - (apply H2; tauto) || - (pattern (decidability p0) in |- *; apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable in |- *; intro H4; apply H1; - tauto - | intro; tauto ]) ]. -Qed. - -Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := - match s with - | E_SPLIT i dl s1 s2 => - match extract_hyp_pos dl (nth_hyps i h) with - | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) - | Tnot (Tand x y) => - if decidability x - then - decompose_solve s1 (Tnot x :: h) ++ - decompose_solve s2 (Tnot y :: h) - else h :: nil - | Timp x y => - if decidability x then - decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) - else h::nil - | _ => h :: nil - end - | E_EXTRACT i dl s1 => - decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) - | E_SOLVE t => execute_omega t h - end. - -Theorem decompose_solve_valid : - forall s : e_step, valid_list_goal (decompose_solve s). -Proof. - intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; - simpl in |- *; intros; - [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); - [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto; - [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl in |- *; tauto - | left; apply H; simpl in |- *; tauto ] - | simpl in |- *; auto ] - | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2; - [ intros H3; left; apply H; simpl in |- *; auto - | intros H3; right; apply H0; simpl in |- *; auto ] - | intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl in |- *; tauto - | left; apply H; simpl in |- *; tauto ] - | simpl in |- *; auto ] ] - | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] - | intros; apply H; simpl in |- *; split; - [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto - | auto ] - | apply omega_valid with (1 := H) ]. -Qed. - -(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) - -Definition valid_lhyps (f : lhyps -> lhyps) := - forall (ep : list Prop) (e : list int) (lp : lhyps), - interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). - -Fixpoint reduce_lhyps (lp : lhyps) : lhyps := - match lp with - | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' - | x :: lp' => x :: reduce_lhyps lp' - | nil => nil (A:=hyps) - end. - -Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. -Proof. - unfold valid_lhyps in |- *; intros ep e lp; elim lp; - [ simpl in |- *; auto - | intros a l HR; elim a; - [ simpl in |- *; tauto - | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ]. -Qed. - -Theorem do_reduce_lhyps : - forall (envp : list Prop) (env : list int) (l : lhyps), - interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. -Proof. - intros envp env l H; apply list_goal_to_hyps; intro H1; - apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; - assumption. -Qed. - -Definition concl_to_hyp (p : proposition) := - if decidability p then Tnot p else TrueTerm. - -Definition do_concl_to_hyp : - forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps), - interp_goal envp env (concl_to_hyp c :: l) -> - interp_goal_concl c envp env l. -Proof. - simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; - [ simpl in |- *; unfold concl_to_hyp in |- *; - pattern (decidability c) in |- *; apply bool_eq_ind; - [ intro H; generalize (decidable_correct envp env c H); - unfold decidable in |- *; simpl in |- *; tauto - | simpl in |- *; intros H1 H2; elim H2; trivial ] - | simpl in |- *; tauto ]. -Qed. - -Definition omega_tactic (t1 : e_step) (t2 : list h_step) - (c : proposition) (l : hyps) := - reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). - -Theorem do_omega : - forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) - (env : list int) (c : proposition) (l : hyps), - interp_list_goal envp env (omega_tactic t1 t2 c l) -> - interp_goal_concl c envp env l. -Proof. - unfold omega_tactic in |- *; intros; apply do_concl_to_hyp; - apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); - apply do_reduce_lhyps; assumption. -Qed. - -End IntOmega. - -(* For now, the above modular construction is instanciated on Z, - in order to retrieve the initial ROmega. *) - -Module ZOmega := IntOmega(Z_as_Int). diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml deleted file mode 100644 index bdec6bf4..00000000 --- a/contrib/romega/const_omega.ml +++ /dev/null @@ -1,350 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -let module_refl_name = "ReflOmegaCore" -let module_refl_path = ["Coq"; "romega"; module_refl_name] - -type result = - Kvar of string - | Kapp of string * Term.constr list - | Kimp of Term.constr * Term.constr - | Kufo;; - -let destructurate t = - let c, args = Term.decompose_app t in - match Term.kind_of_term c, args with - | Term.Const sp, args -> - Kapp (Names.string_of_id - (Nametab.id_of_global (Libnames.ConstRef sp)), - args) - | Term.Construct csp , args -> - Kapp (Names.string_of_id - (Nametab.id_of_global (Libnames.ConstructRef csp)), - args) - | Term.Ind isp, args -> - Kapp (Names.string_of_id - (Nametab.id_of_global (Libnames.IndRef isp)), - args) - | Term.Var id,[] -> Kvar(Names.string_of_id id) - | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) - | Term.Prod (Names.Name _,_,_),[] -> - Util.error "Omega: Not a quantifier-free goal" - | _ -> Kufo - -exception Destruct - -let dest_const_apply t = - let f,args = Term.decompose_app t in - let ref = - match Term.kind_of_term f with - | Term.Const sp -> Libnames.ConstRef sp - | Term.Construct csp -> Libnames.ConstructRef csp - | Term.Ind isp -> Libnames.IndRef isp - | _ -> raise Destruct - in Nametab.id_of_global ref, args - -let logic_dir = ["Coq";"Logic";"Decidable"] - -let coq_modules = - Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules - @ [["Coq"; "Lists"; "List"]] - @ [module_refl_path] - @ [module_refl_path@["ZOmega"]] - -let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules - -(* Logic *) -let coq_eq = lazy(constant "eq") -let coq_refl_equal = lazy(constant "refl_equal") -let coq_and = lazy(constant "and") -let coq_not = lazy(constant "not") -let coq_or = lazy(constant "or") -let coq_True = lazy(constant "True") -let coq_False = lazy(constant "False") -let coq_I = lazy(constant "I") - -(* ReflOmegaCore/ZOmega *) - -let coq_h_step = lazy (constant "h_step") -let coq_pair_step = lazy (constant "pair_step") -let coq_p_left = lazy (constant "P_LEFT") -let coq_p_right = lazy (constant "P_RIGHT") -let coq_p_invert = lazy (constant "P_INVERT") -let coq_p_step = lazy (constant "P_STEP") - -let coq_t_int = lazy (constant "Tint") -let coq_t_plus = lazy (constant "Tplus") -let coq_t_mult = lazy (constant "Tmult") -let coq_t_opp = lazy (constant "Topp") -let coq_t_minus = lazy (constant "Tminus") -let coq_t_var = lazy (constant "Tvar") - -let coq_proposition = lazy (constant "proposition") -let coq_p_eq = lazy (constant "EqTerm") -let coq_p_leq = lazy (constant "LeqTerm") -let coq_p_geq = lazy (constant "GeqTerm") -let coq_p_lt = lazy (constant "LtTerm") -let coq_p_gt = lazy (constant "GtTerm") -let coq_p_neq = lazy (constant "NeqTerm") -let coq_p_true = lazy (constant "TrueTerm") -let coq_p_false = lazy (constant "FalseTerm") -let coq_p_not = lazy (constant "Tnot") -let coq_p_or = lazy (constant "Tor") -let coq_p_and = lazy (constant "Tand") -let coq_p_imp = lazy (constant "Timp") -let coq_p_prop = lazy (constant "Tprop") - -(* Constructors for shuffle tactic *) -let coq_t_fusion = lazy (constant "t_fusion") -let coq_f_equal = lazy (constant "F_equal") -let coq_f_cancel = lazy (constant "F_cancel") -let coq_f_left = lazy (constant "F_left") -let coq_f_right = lazy (constant "F_right") - -(* Constructors for reordering tactics *) -let coq_c_do_both = lazy (constant "C_DO_BOTH") -let coq_c_do_left = lazy (constant "C_LEFT") -let coq_c_do_right = lazy (constant "C_RIGHT") -let coq_c_do_seq = lazy (constant "C_SEQ") -let coq_c_nop = lazy (constant "C_NOP") -let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") -let coq_c_opp_opp = lazy (constant "C_OPP_OPP") -let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") -let coq_c_opp_one = lazy (constant "C_OPP_ONE") -let coq_c_reduce = lazy (constant "C_REDUCE") -let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") -let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") -let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") -let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") -let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") -let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") -let coq_c_red0 = lazy (constant "C_RED0") -let coq_c_red1 = lazy (constant "C_RED1") -let coq_c_red2 = lazy (constant "C_RED2") -let coq_c_red3 = lazy (constant "C_RED3") -let coq_c_red4 = lazy (constant "C_RED4") -let coq_c_red5 = lazy (constant "C_RED5") -let coq_c_red6 = lazy (constant "C_RED6") -let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") -let coq_c_minus = lazy (constant "C_MINUS") -let coq_c_mult_comm = lazy (constant "C_MULT_COMM") - -let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") -let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") -let coq_s_div_approx = lazy (constant "O_DIV_APPROX") -let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") -let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") -let coq_s_sum = lazy (constant "O_SUM") -let coq_s_state = lazy (constant "O_STATE") -let coq_s_contradiction = lazy (constant "O_CONTRADICTION") -let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") -let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") -let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") -let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") -let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") - -(* construction for the [extract_hyp] tactic *) -let coq_direction = lazy (constant "direction") -let coq_d_left = lazy (constant "D_left") -let coq_d_right = lazy (constant "D_right") -let coq_d_mono = lazy (constant "D_mono") - -let coq_e_split = lazy (constant "E_SPLIT") -let coq_e_extract = lazy (constant "E_EXTRACT") -let coq_e_solve = lazy (constant "E_SOLVE") - -let coq_interp_sequent = lazy (constant "interp_goal_concl") -let coq_do_omega = lazy (constant "do_omega") - -(* \subsection{Construction d'expressions} *) - -let do_left t = - if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) - -let do_right t = - if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) - -let do_both t1 t2 = - if t1 = Lazy.force coq_c_nop then do_right t2 - else if t2 = Lazy.force coq_c_nop then do_left t1 - else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) - -let do_seq t1 t2 = - if t1 = Lazy.force coq_c_nop then t2 - else if t2 = Lazy.force coq_c_nop then t1 - else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) - -let rec do_list = function - | [] -> Lazy.force coq_c_nop - | [x] -> x - | (x::l) -> do_seq x (do_list l) - -(* Nat *) - -let coq_S = lazy(constant "S") -let coq_O = lazy(constant "O") - -let rec mk_nat = function - | 0 -> Lazy.force coq_O - | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) - -(* Lists *) - -let coq_cons = lazy (constant "cons") -let coq_nil = lazy (constant "nil") - -let mk_list typ l = - let rec loop = function - | [] -> - Term.mkApp (Lazy.force coq_nil, [|typ|]) - | (step :: l) -> - Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in - loop l - -let mk_plist l = mk_list Term.mkProp l - -let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l - - -type parse_term = - | Tplus of Term.constr * Term.constr - | Tmult of Term.constr * Term.constr - | Tminus of Term.constr * Term.constr - | Topp of Term.constr - | Tsucc of Term.constr - | Tnum of Bigint.bigint - | Tother - -type parse_rel = - | Req of Term.constr * Term.constr - | Rne of Term.constr * Term.constr - | Rlt of Term.constr * Term.constr - | Rle of Term.constr * Term.constr - | Rgt of Term.constr * Term.constr - | Rge of Term.constr * Term.constr - | Rtrue - | Rfalse - | Rnot of Term.constr - | Ror of Term.constr * Term.constr - | Rand of Term.constr * Term.constr - | Rimp of Term.constr * Term.constr - | Riff of Term.constr * Term.constr - | Rother - -let parse_logic_rel c = - try match destructurate c with - | Kapp("True",[]) -> Rtrue - | Kapp("False",[]) -> Rfalse - | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) - | Kapp("and",[t1;t2]) -> Rand (t1,t2) - | Kimp(t1,t2) -> Rimp (t1,t2) - | Kapp("iff",[t1;t2]) -> Riff (t1,t2) - | _ -> Rother - with e when Logic.catchable_exception e -> Rother - - -module type Int = sig - val typ : Term.constr Lazy.t - val plus : Term.constr Lazy.t - val mult : Term.constr Lazy.t - val opp : Term.constr Lazy.t - val minus : Term.constr Lazy.t - - val mk : Bigint.bigint -> Term.constr - val parse_term : Term.constr -> parse_term - val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel - (* check whether t is built only with numbers and + * - *) - val is_scalar : Term.constr -> bool -end - -module Z : Int = struct - -let typ = lazy (constant "Z") -let plus = lazy (constant "Zplus") -let mult = lazy (constant "Zmult") -let opp = lazy (constant "Zopp") -let minus = lazy (constant "Zminus") - -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") - -let recognize t = - let rec loop t = - let f,l = dest_const_apply t in - match Names.string_of_id f,l with - "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> failwith "not a number" in - let f,l = dest_const_apply t in - match Names.string_of_id f,l with - "Zpos",[t] -> loop t - | "Zneg",[t] -> Bigint.neg (loop t) - | "Z0",[] -> Bigint.zero - | _ -> failwith "not a number";; - -let rec mk_positive n = - if n=Bigint.one then Lazy.force coq_xH - else - let (q,r) = Bigint.euclid n Bigint.two in - Term.mkApp - ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) - -let mk_Z n = - if n = Bigint.zero then Lazy.force coq_Z0 - else if Bigint.is_strictly_pos n then - Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) - else - Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |]) - -let mk = mk_Z - -let parse_term t = - try match destructurate t with - | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Zopp",[t]) -> Topp t - | Kapp("Zsucc",[t]) -> Tsucc t - | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with _ -> Tother) - | _ -> Tother - with e when Logic.catchable_exception e -> Tother - -let parse_rel gl t = - try match destructurate t with - | Kapp("eq",[typ;t1;t2]) - when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) - | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Zle",[t1;t2]) -> Rle (t1,t2) - | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Zge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel t - with e when Logic.catchable_exception e -> Rother - -let is_scalar t = - let rec aux t = match destructurate t with - | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 - | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true - | _ -> false in - try aux t with _ -> false - -end diff --git a/contrib/romega/const_omega.mli b/contrib/romega/const_omega.mli deleted file mode 100644 index 0f00e918..00000000 --- a/contrib/romega/const_omega.mli +++ /dev/null @@ -1,176 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - - -(** Coq objects used in romega *) - -(* from Logic *) -val coq_refl_equal : Term.constr lazy_t -val coq_and : Term.constr lazy_t -val coq_not : Term.constr lazy_t -val coq_or : Term.constr lazy_t -val coq_True : Term.constr lazy_t -val coq_False : Term.constr lazy_t -val coq_I : Term.constr lazy_t - -(* from ReflOmegaCore/ZOmega *) -val coq_h_step : Term.constr lazy_t -val coq_pair_step : Term.constr lazy_t -val coq_p_left : Term.constr lazy_t -val coq_p_right : Term.constr lazy_t -val coq_p_invert : Term.constr lazy_t -val coq_p_step : Term.constr lazy_t - -val coq_t_int : Term.constr lazy_t -val coq_t_plus : Term.constr lazy_t -val coq_t_mult : Term.constr lazy_t -val coq_t_opp : Term.constr lazy_t -val coq_t_minus : Term.constr lazy_t -val coq_t_var : Term.constr lazy_t - -val coq_proposition : Term.constr lazy_t -val coq_p_eq : Term.constr lazy_t -val coq_p_leq : Term.constr lazy_t -val coq_p_geq : Term.constr lazy_t -val coq_p_lt : Term.constr lazy_t -val coq_p_gt : Term.constr lazy_t -val coq_p_neq : Term.constr lazy_t -val coq_p_true : Term.constr lazy_t -val coq_p_false : Term.constr lazy_t -val coq_p_not : Term.constr lazy_t -val coq_p_or : Term.constr lazy_t -val coq_p_and : Term.constr lazy_t -val coq_p_imp : Term.constr lazy_t -val coq_p_prop : Term.constr lazy_t - -val coq_f_equal : Term.constr lazy_t -val coq_f_cancel : Term.constr lazy_t -val coq_f_left : Term.constr lazy_t -val coq_f_right : Term.constr lazy_t - -val coq_c_do_both : Term.constr lazy_t -val coq_c_do_left : Term.constr lazy_t -val coq_c_do_right : Term.constr lazy_t -val coq_c_do_seq : Term.constr lazy_t -val coq_c_nop : Term.constr lazy_t -val coq_c_opp_plus : Term.constr lazy_t -val coq_c_opp_opp : Term.constr lazy_t -val coq_c_opp_mult_r : Term.constr lazy_t -val coq_c_opp_one : Term.constr lazy_t -val coq_c_reduce : Term.constr lazy_t -val coq_c_mult_plus_distr : Term.constr lazy_t -val coq_c_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_l : Term.constr lazy_t -val coq_c_plus_permute : Term.constr lazy_t -val coq_c_plus_comm : Term.constr lazy_t -val coq_c_red0 : Term.constr lazy_t -val coq_c_red1 : Term.constr lazy_t -val coq_c_red2 : Term.constr lazy_t -val coq_c_red3 : Term.constr lazy_t -val coq_c_red4 : Term.constr lazy_t -val coq_c_red5 : Term.constr lazy_t -val coq_c_red6 : Term.constr lazy_t -val coq_c_mult_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_reduced : Term.constr lazy_t -val coq_c_minus : Term.constr lazy_t -val coq_c_mult_comm : Term.constr lazy_t - -val coq_s_constant_not_nul : Term.constr lazy_t -val coq_s_constant_neg : Term.constr lazy_t -val coq_s_div_approx : Term.constr lazy_t -val coq_s_not_exact_divide : Term.constr lazy_t -val coq_s_exact_divide : Term.constr lazy_t -val coq_s_sum : Term.constr lazy_t -val coq_s_state : Term.constr lazy_t -val coq_s_contradiction : Term.constr lazy_t -val coq_s_merge_eq : Term.constr lazy_t -val coq_s_split_ineq : Term.constr lazy_t -val coq_s_constant_nul : Term.constr lazy_t -val coq_s_negate_contradict : Term.constr lazy_t -val coq_s_negate_contradict_inv : Term.constr lazy_t - -val coq_direction : Term.constr lazy_t -val coq_d_left : Term.constr lazy_t -val coq_d_right : Term.constr lazy_t -val coq_d_mono : Term.constr lazy_t - -val coq_e_split : Term.constr lazy_t -val coq_e_extract : Term.constr lazy_t -val coq_e_solve : Term.constr lazy_t - -val coq_interp_sequent : Term.constr lazy_t -val coq_do_omega : Term.constr lazy_t - -(** Building expressions *) - -val do_left : Term.constr -> Term.constr -val do_right : Term.constr -> Term.constr -val do_both : Term.constr -> Term.constr -> Term.constr -val do_seq : Term.constr -> Term.constr -> Term.constr -val do_list : Term.constr list -> Term.constr - -val mk_nat : int -> Term.constr -val mk_list : Term.constr -> Term.constr list -> Term.constr -val mk_plist : Term.types list -> Term.types -val mk_shuffle_list : Term.constr list -> Term.constr - -(** Analyzing a coq term *) - -(* The generic result shape of the analysis of a term. - One-level depth, except when a number is found *) -type parse_term = - Tplus of Term.constr * Term.constr - | Tmult of Term.constr * Term.constr - | Tminus of Term.constr * Term.constr - | Topp of Term.constr - | Tsucc of Term.constr - | Tnum of Bigint.bigint - | Tother - -(* The generic result shape of the analysis of a relation. - One-level depth. *) -type parse_rel = - Req of Term.constr * Term.constr - | Rne of Term.constr * Term.constr - | Rlt of Term.constr * Term.constr - | Rle of Term.constr * Term.constr - | Rgt of Term.constr * Term.constr - | Rge of Term.constr * Term.constr - | Rtrue - | Rfalse - | Rnot of Term.constr - | Ror of Term.constr * Term.constr - | Rand of Term.constr * Term.constr - | Rimp of Term.constr * Term.constr - | Riff of Term.constr * Term.constr - | Rother - -(* A module factorizing what we should now about the number representation *) -module type Int = - sig - (* the coq type of the numbers *) - val typ : Term.constr Lazy.t - (* the operations on the numbers *) - val plus : Term.constr Lazy.t - val mult : Term.constr Lazy.t - val opp : Term.constr Lazy.t - val minus : Term.constr Lazy.t - (* building a coq number *) - val mk : Bigint.bigint -> Term.constr - (* parsing a term (one level, except if a number is found) *) - val parse_term : Term.constr -> parse_term - (* parsing a relation expression, including = < <= >= > *) - val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel - (* Is a particular term only made of numbers and + * - ? *) - val is_scalar : Term.constr -> bool - end - -(* Currently, we only use Z numbers *) -module Z : Int diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4 deleted file mode 100644 index 39b6c210..00000000 --- a/contrib/romega/g_romega.ml4 +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Refl_omega -open Refiner - -let romega_tactic l = - let tacs = List.map - (function - | "nat" -> Tacinterp.interp <:tactic<zify_nat>> - | "positive" -> Tacinterp.interp <:tactic<zify_positive>> - | "N" -> Tacinterp.interp <:tactic<zify_N>> - | "Z" -> Tacinterp.interp <:tactic<zify_op>> - | s -> Util.error ("No ROmega knowledge base for type "^s)) - (Util.list_uniquize (List.sort compare l)) - in - tclTHEN - (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - (tclTHEN - (* because of the contradiction process in (r)omega, - we'd better leave as little as possible in the conclusion, - for an easier decidability argument. *) - Tactics.intros - total_reflexive_omega_tactic) - - -TACTIC EXTEND romega -| [ "romega" ] -> [ romega_tactic [] ] -END - -TACTIC EXTEND romega' -| [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic (List.map Names.string_of_id l) ] -| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] -END diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml deleted file mode 100644 index fc4f7a8f..00000000 --- a/contrib/romega/refl_omega.ml +++ /dev/null @@ -1,1299 +0,0 @@ -(************************************************************************* - - PROJET RNRT Calife - 2001 - Author: Pierre Crégut - France Télécom R&D - Licence : LGPL version 2.1 - - *************************************************************************) - -open Util -open Const_omega -module OmegaSolver = Omega.MakeOmegaSolver (Bigint) -open OmegaSolver - -(* \section{Useful functions and flags} *) -(* Especially useful debugging functions *) -let debug = ref false - -let show_goal gl = - if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl - -let pp i = print_int i; print_newline (); flush stdout - -(* More readable than the prefix notation *) -let (>>) = Tacticals.tclTHEN - -let mkApp = Term.mkApp - -(* \section{Types} - \subsection{How to walk in a term} - To represent how to get to a proposition. Only choice points are - kept (branch to choose in a disjunction and identifier of the disjunctive - connector) *) -type direction = Left of int | Right of int - -(* Step to find a proposition (operators are at most binary). A list is - a path *) -type occ_step = O_left | O_right | O_mono -type occ_path = occ_step list - -(* chemin identifiant une proposition sous forme du nom de l'hypothèse et - d'une liste de pas à partir de la racine de l'hypothèse *) -type occurence = {o_hyp : Names.identifier; o_path : occ_path} - -(* \subsection{refiable formulas} *) -type oformula = - (* integer *) - | Oint of Bigint.bigint - (* recognized binary and unary operations *) - | Oplus of oformula * oformula - | Omult of oformula * oformula - | Ominus of oformula * oformula - | Oopp of oformula - (* an atome in the environment *) - | Oatom of int - (* weird expression that cannot be translated *) - | Oufo of oformula - -(* Operators for comparison recognized by Omega *) -type comparaison = Eq | Leq | Geq | Gt | Lt | Neq - -(* Type des prédicats réifiés (fragment de calcul propositionnel. Les - * quantifications sont externes au langage) *) -type oproposition = - Pequa of Term.constr * oequation - | Ptrue - | Pfalse - | Pnot of oproposition - | Por of int * oproposition * oproposition - | Pand of int * oproposition * oproposition - | Pimp of int * oproposition * oproposition - | Pprop of Term.constr - -(* Les équations ou proposiitions atomiques utiles du calcul *) -and oequation = { - e_comp: comparaison; (* comparaison *) - e_left: oformula; (* formule brute gauche *) - e_right: oformula; (* formule brute droite *) - e_trace: Term.constr; (* tactique de normalisation *) - e_origin: occurence; (* l'hypothèse dont vient le terme *) - e_negated: bool; (* vrai si apparait en position nié - après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont - dépend l'accès à l'équation avec la - direction (branche) pour y accéder *) - e_omega: afine (* la fonction normalisée *) - } - -(* \subsection{Proof context} - This environment codes - \begin{itemize} - \item the terms and propositions that are given as - parameters of the reified proof (and are represented as variables in the - reified goals) - \item translation functions linking the decision procedure and the Coq proof - \end{itemize} *) - -type environment = { - (* La liste des termes non reifies constituant l'environnement global *) - mutable terms : Term.constr list; - (* La meme chose pour les propositions *) - mutable props : Term.constr list; - (* Les variables introduites par omega *) - mutable om_vars : (oformula * int) list; - (* Traduction des indices utilisés ici en les indices finaux utilisés par - * la tactique Omega après dénombrement des variables utiles *) - real_indices : (int,int) Hashtbl.t; - mutable cnt_connectors : int; - equations : (int,oequation) Hashtbl.t; - constructors : (int, occurence) Hashtbl.t -} - -(* \subsection{Solution tree} - Définition d'une solution trouvée par Omega sous la forme d'un identifiant, - d'un ensemble d'équation dont dépend la solution et d'une trace *) -(* La liste des dépendances est triée et sans redondance *) -type solution = { - s_index : int; - s_equa_deps : int list; - s_trace : action list } - -(* Arbre de solution résolvant complètement un ensemble de systèmes *) -type solution_tree = - Leaf of solution - (* un noeud interne représente un point de branchement correspondant à - l'élimination d'un connecteur générant plusieurs buts - (typ. disjonction). Le premier argument - est l'identifiant du connecteur *) - | Tree of int * solution_tree * solution_tree - -(* Représentation de l'environnement extrait du but initial sous forme de - chemins pour extraire des equations ou d'hypothèses *) - -type context_content = - CCHyp of occurence - | CCEqua of int - -(* \section{Specific utility functions to handle base types} *) -(* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Names.id_of_string "__goal__" - -(* Initialisation de l'environnement de réification de la tactique *) -let new_environment () = { - terms = []; props = []; om_vars = []; cnt_connectors = 0; - real_indices = Hashtbl.create 7; - equations = Hashtbl.create 7; - constructors = Hashtbl.create 7; -} - -(* Génération d'un nom d'équation *) -let new_connector_id env = - env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors - -(* Calcul de la branche complémentaire *) -let barre = function Left x -> Right x | Right x -> Left x - -(* Identifiant associé à une branche *) -let indice = function Left x | Right x -> x - -(* Affichage de l'environnement de réification (termes et propositions) *) -let print_env_reification env = - let rec loop c i = function - [] -> Printf.printf " ===============================\n\n" - | t :: l -> - Printf.printf " (%c%02d) := " c i; - Pp.ppnl (Printer.pr_lconstr t); - Pp.flush_all (); - loop c (succ i) l in - print_newline (); - Printf.printf " ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props; - Printf.printf " ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms - - -(* \subsection{Gestion des environnements de variable pour Omega} *) -(* generation d'identifiant d'equation pour Omega *) - -let new_omega_eq, rst_omega_eq = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), - (function () -> cpt:=0) - -(* generation d'identifiant de variable pour Omega *) - -let new_omega_var, rst_omega_var = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), - (function () -> cpt:=0) - -(* Affichage des variables d'un système *) - -let display_omega_var i = Printf.sprintf "OV%d" i - -(* Recherche la variable codant un terme pour Omega et crée la variable dans - l'environnement si il n'existe pas. Cas ou la variable dans Omega représente - le terme d'un monome (le plus souvent un atome) *) - -let intern_omega env t = - begin try List.assoc t env.om_vars - with Not_found -> - let v = new_omega_var () in - env.om_vars <- (t,v) :: env.om_vars; v - end - -(* Ajout forcé d'un lien entre un terme et une variable Cas où la - variable est créée par Omega et où il faut la lier après coup à un atome - réifié introduit de force *) -let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars - -(* Récupère le terme associé à une variable *) -let unintern_omega env id = - let rec loop = function - [] -> failwith "unintern" - | ((t,j)::l) -> if id = j then t else loop l in - loop env.om_vars - -(* \subsection{Gestion des environnements de variable pour la réflexion} - Gestion des environnements de traduction entre termes des constructions - non réifiés et variables des termes reifies. Attention il s'agit de - l'environnement initial contenant tout. Il faudra le réduire après - calcul des variables utiles. *) - -let add_reified_atom t env = - try list_index0 t env.terms - with Not_found -> - let i = List.length env.terms in - env.terms <- env.terms @ [t]; i - -let get_reified_atom env = - try List.nth env.terms with _ -> failwith "get_reified_atom" - -(* \subsection{Gestion de l'environnement de proposition pour Omega} *) -(* ajout d'une proposition *) -let add_prop env t = - try list_index0 t env.props - with Not_found -> - let i = List.length env.props in env.props <- env.props @ [t]; i - -(* accès a une proposition *) -let get_prop v env = try List.nth v env with _ -> failwith "get_prop" - -(* \subsection{Gestion du nommage des équations} *) -(* Ajout d'une equation dans l'environnement de reification *) -let add_equation env e = - let id = e.e_omega.id in - try let _ = Hashtbl.find env.equations id in () - with Not_found -> Hashtbl.add env.equations id e - -(* accès a une equation *) -let get_equation env id = - try Hashtbl.find env.equations id - with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e - -(* Affichage des termes réifiés *) -let rec oprint ch = function - | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) - | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 - | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 - | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 - | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 - | Oatom n -> Printf.fprintf ch "V%02d" n - | Oufo x -> Printf.fprintf ch "?" - -let rec pprint ch = function - Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - let connector = - match comp with - Eq -> "=" | Leq -> "<=" | Geq -> ">=" - | Gt -> ">" | Lt -> "<" | Neq -> "!=" in - Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 - | Ptrue -> Printf.fprintf ch "TT" - | Pfalse -> Printf.fprintf ch "FF" - | Pnot t -> Printf.fprintf ch "not(%a)" pprint t - | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 - | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 - | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 - | Pprop c -> Printf.fprintf ch "Prop" - -let rec weight env = function - | Oint _ -> -1 - | Oopp c -> weight env c - | Omult(c,_) -> weight env c - | Oplus _ -> failwith "weight" - | Ominus _ -> failwith "weight minus" - | Oufo _ -> -1 - | Oatom _ as c -> (intern_omega env c) - -(* \section{Passage entre oformules et représentation interne de Omega} *) - -(* \subsection{Oformula vers Omega} *) - -let omega_of_oformula env kind = - let rec loop accu = function - | Oplus(Omult(v,Oint n),r) -> - loop ({v=intern_omega env v; c=n} :: accu) r - | Oint n -> - let id = new_omega_eq () in - (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; - constant = n; id = id} - | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in - loop [] - -(* \subsection{Omega vers Oformula} *) - -let rec oformula_of_omega env af = - let rec loop = function - | ({v=v; c=n}::r) -> - Oplus(Omult(unintern_omega env v,Oint n),loop r) - | [] -> Oint af.constant in - loop af.body - -let app f v = mkApp(Lazy.force f,v) - -(* \subsection{Oformula vers COQ reel} *) - -let rec coq_of_formula env t = - let rec loop = function - | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |] - | Oopp t -> app Z.opp [| loop t |] - | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] - | Oint v -> Z.mk v - | Oufo t -> loop t - | Oatom var -> - (* attention ne traite pas les nouvelles variables si on ne les - * met pas dans env.term *) - get_reified_atom env var - | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in - loop t - -(* \subsection{Oformula vers COQ reifié} *) - -let reified_of_atom env i = - try Hashtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" i; - Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; - raise Not_found - -let rec reified_of_formula env = function - | Oplus (t1,t2) -> - app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oopp t -> - app coq_t_opp [| reified_of_formula env t |] - | Omult(t1,t2) -> - app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oint v -> app coq_t_int [| Z.mk v |] - | Oufo t -> reified_of_formula env t - | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] - | Ominus(t1,t2) -> - app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] - -let reified_of_formula env f = - begin try reified_of_formula env f with e -> oprint stderr f; raise e end - -let rec reified_of_proposition env = function - Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> - app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> - app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> - app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> - app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> - app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> - app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Ptrue -> Lazy.force coq_p_true - | Pfalse -> Lazy.force coq_p_false - | Pnot t -> - app coq_p_not [| reified_of_proposition env t |] - | Por (_,t1,t2) -> - app coq_p_or - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pand(_,t1,t2) -> - app coq_p_and - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pimp(_,t1,t2) -> - app coq_p_imp - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] - -let reified_of_proposition env f = - begin try reified_of_proposition env f - with e -> pprint stderr f; raise e end - -(* \subsection{Omega vers COQ réifié} *) - -let reified_of_omega env body constant = - let coeff_constant = - app coq_t_int [| Z.mk constant |] in - let mk_coeff {c=c; v=v} t = - let coef = - app coq_t_mult - [| reified_of_formula env (unintern_omega env v); - app coq_t_int [| Z.mk c |] |] in - app coq_t_plus [|coef; t |] in - List.fold_right mk_coeff body coeff_constant - -let reified_of_omega env body c = - begin try - reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e - end - -(* \section{Opérations sur les équations} -Ces fonctions préparent les traces utilisées par la tactique réfléchie -pour faire des opérations de normalisation sur les équations. *) - -(* \subsection{Extractions des variables d'une équation} *) -(* Extraction des variables d'une équation. *) -(* Chaque fonction retourne une liste triée sans redondance *) - -let (@@) = list_merge_uniq compare - -let rec vars_of_formula = function - | Oint _ -> [] - | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) - | Oopp e -> vars_of_formula e - | Oatom i -> [i] - | Oufo _ -> [] - -let rec vars_of_equations = function - | [] -> [] - | e::l -> - (vars_of_formula e.e_left) @@ - (vars_of_formula e.e_right) @@ - (vars_of_equations l) - -let rec vars_of_prop = function - | Pequa(_,e) -> vars_of_equations [e] - | Pnot p -> vars_of_prop p - | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pprop _ | Ptrue | Pfalse -> [] - -(* \subsection{Multiplication par un scalaire} *) - -let rec scalar n = function - Oplus(t1,t2) -> - let tac1,t1' = scalar n t1 and - tac2,t2' = scalar n t2 in - do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) - | Omult(t1,t2) -> - Util.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> do_list [], Omult(t,Oint n) - | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) - | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) - | Ominus _ -> failwith "scalar minus" - -(* \subsection{Propagation de l'inversion} *) - -let rec negate = function - Oplus(t1,t2) -> - let tac1,t1' = negate t1 and - tac2,t2' = negate t2 in - do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_opp_opp], t - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) - | Omult(t1,t2) -> - Util.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> - do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) - | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) - | Oufo c -> do_list [], Oufo (Oopp c) - | Ominus _ -> failwith "negate minus" - -let rec norm l = (List.length l) - -(* \subsection{Mélange (fusion) de deux équations} *) -(* \subsubsection{Version avec coefficients} *) -let rec shuffle_path k1 e1 k2 e2 = - let rec loop = function - (({c=c1;v=v1}::l1) as l1'), - (({c=c2;v=v2}::l2) as l2') -> - if v1 = v2 then - if k1*c1 + k2 * c2 = zero then ( - Lazy.force coq_f_cancel :: loop (l1,l2)) - else ( - Lazy.force coq_f_equal :: loop (l1,l2) ) - else if v1 > v2 then ( - Lazy.force coq_f_left :: loop(l1,l2')) - else ( - Lazy.force coq_f_right :: loop(l1',l2)) - | ({c=c1;v=v1}::l1), [] -> - Lazy.force coq_f_left :: loop(l1,[]) - | [],({c=c2;v=v2}::l2) -> - Lazy.force coq_f_right :: loop([],l2) - | [],[] -> flush stdout; [] in - mk_shuffle_list (loop (e1,e2)) - -(* \subsubsection{Version sans coefficients} *) -let rec shuffle env (t1,t2) = - match t1,t2 with - Oplus(l1,r1), Oplus(l2,r2) -> - if weight env l1 > weight env l2 then - let l_action,t' = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') - else - let l_action,t' = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - | Oplus(l1,r1), t2 -> - if weight env l1 > weight env t2 then - let (l_action,t') = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') - else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight env l2 > weight env t1 then - let (l_action,t') = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - else do_list [],Oplus(t1,t2) - | Oint t1,Oint t2 -> - do_list [Lazy.force coq_c_reduce], Oint(t1+t2) - | t1,t2 -> - if weight env t1 < weight env t2 then - do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - else do_list [],Oplus(t1,t2) - -(* \subsection{Fusion avec réduction} *) - -let shrink_pair f1 f2 = - begin match f1,f2 with - Oatom v,Oatom _ -> - Lazy.force coq_c_red1, Omult(Oatom v,Oint two) - | Oatom v, Omult(_,c2) -> - Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) - | Omult (v1,c1),Oatom v -> - Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) - | Omult (Oatom v,c1),Omult (v2,c2) -> - Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) - | t1,t2 -> - oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); - flush Pervasives.stdout; Util.error "shrink.1" - end - -(* \subsection{Calcul d'une sous formule constante} *) - -let reduce_factor = function - Oatom v -> - let r = Omult(Oatom v,Oint one) in - [Lazy.force coq_c_red0],r - | Omult(Oatom v,Oint n) as f -> [],f - | Omult(Oatom v,c) -> - let rec compute = function - Oint n -> n - | Oplus(t1,t2) -> compute t1 + compute t2 - | _ -> Util.error "condense.1" in - [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) - | t -> Util.error "reduce_factor.1" - -(* \subsection{Réordonnancement} *) - -let rec condense env = function - Oplus(f1,(Oplus(f2,r) as t)) -> - if weight env f1 = weight env f2 then begin - let shrink_tac,t = shrink_pair f1 f2 in - let assoc_tac = Lazy.force coq_c_plus_assoc_l in - let tac_list,t' = condense env (Oplus(t,r)) in - assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env t in - [do_both (do_list tac) (do_list tac')], Oplus(f,t') - end - | Oplus(f1,Oint n) -> - let tac,f1' = reduce_factor f1 in - [do_left (do_list tac)],Oplus(f1',Oint n) - | Oplus(f1,f2) -> - if weight env f1 = weight env f2 then begin - let tac_shrink,t = shrink_pair f1 f2 in - let tac,t' = condense env t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env f2 in - [do_both (do_list tac) (do_list tac')],Oplus(f,t') - end - | (Oint _ as t)-> [],t - | t -> - let tac,t' = reduce_factor t in - let final = Oplus(t',Oint zero) in - tac @ [Lazy.force coq_c_red6], final - -(* \subsection{Elimination des zéros} *) - -let rec clear_zero = function - Oplus(Omult(Oatom v,Oint n),r) when n=zero -> - let tac',t = clear_zero r in - Lazy.force coq_c_red5 :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero r in - (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) - | t -> [],t;; - -(* \subsection{Transformation des hypothèses} *) - -let rec reduce env = function - Oplus(t1,t2) -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - let trace3,t' = shuffle env (t1',t2') in - t', do_list [do_both trace1 trace2; trace3] - | Ominus(t1,t2) -> - let t,trace = reduce env (Oplus(t1, Oopp t2)) in - t, do_list [Lazy.force coq_c_minus; trace] - | Omult(t1,t2) as t -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - begin match t1',t2' with - | (_, Oint n) -> - let tac,t' = scalar n t1' in - t', do_list [do_both trace1 trace2; tac] - | (Oint n,_) -> - let tac,t' = scalar n t2' in - t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] - | _ -> Oufo t, Lazy.force coq_c_nop - end - | Oopp t -> - let t',trace = reduce env t in - let trace',t'' = negate t' in - t'', do_list [do_left trace; trace'] - | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop - -let normalize_linear_term env t = - let t1,trace1 = reduce env t in - let trace2,t2 = condense env t1 in - let trace3,t3 = clear_zero t2 in - do_list [trace1; do_list trace2; do_list trace3], t3 - -(* Cette fonction reproduit très exactement le comportement de [p_invert] *) -let negate_oper = function - Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq - -let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = - let mk_step t1 t2 f kind = - let t = f t1 t2 in - let trace, oterm = normalize_linear_term env t in - let equa = omega_of_oformula env kind oterm in - { e_comp = oper; e_left = t1; e_right = t2; - e_negated = negated; e_depends = depends; - e_origin = { o_hyp = origin; o_path = List.rev path }; - e_trace = trace; e_omega = equa } in - try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA - | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE - | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ - | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ - | Lt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) - INEQ - | Gt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) - INEQ - with e when Logic.catchable_exception e -> raise e - -(* \section{Compilation des hypothèses} *) - -let rec oformula_of_constr env t = - match Z.parse_term t with - | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 - | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> - binop env (fun x y -> Omult(x,y)) t1 t2 - | Topp t -> Oopp(oformula_of_constr env t) - | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) - | Tnum n -> Oint n - | _ -> Oatom (add_reified_atom t env) - -and binop env c t1 t2 = - let t1' = oformula_of_constr env t1 in - let t2' = oformula_of_constr env t2 in - c t1' t2' - -and binprop env (neg2,depends,origin,path) - add_to_depends neg1 gl c t1 t2 = - let i = new_connector_id env in - let depends1 = if add_to_depends then Left i::depends else depends in - let depends2 = if add_to_depends then Right i::depends else depends in - if add_to_depends then - Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; - let t1' = - oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in - let t2' = - oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in - (* On numérote le connecteur dans l'environnement. *) - c i t1' t2' - -and mk_equation env ctxt c connector t1 t2 = - let t1' = oformula_of_constr env t1 in - let t2' = oformula_of_constr env t2 in - (* On ajoute l'equation dans l'environnement. *) - let omega = normalize_equation env ctxt (connector,t1',t2') in - add_equation env omega; - Pequa (c,omega) - -and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = - match Z.parse_rel gl c with - | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 - | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 - | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 - | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 - | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 - | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 - | Rtrue -> Ptrue - | Rfalse -> Pfalse - | Rnot t -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in - Pnot t' - | Ror (t1,t2) -> - binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Rand (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) t1 t2 - | Rimp (t1,t2) -> - binprop env ctxt (not negated) (not negated) gl - (fun i x y -> Pimp(i,x,y)) t1 t2 - | Riff (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) - | _ -> Pprop c - -(* Destructuration des hypothèses et de la conclusion *) - -let reify_gl env gl = - let concl = Tacmach.pf_concl gl in - let t_concl = - Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in - if !debug then begin - Printf.printf "REIFED PROBLEM\n\n"; - Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" - end; - let rec loop = function - (i,t) :: lhyps -> - let t' = oproposition_of_constr env (false,[],i,[]) gl t in - if !debug then begin - Printf.printf " %s: " (Names.string_of_id i); - pprint stdout t'; - Printf.printf "\n" - end; - (i,t') :: loop lhyps - | [] -> - if !debug then print_env_reification env; - [] in - let t_lhyps = loop (Tacmach.pf_hyps_types gl) in - (id_concl,t_concl) :: t_lhyps - -let rec destructurate_pos_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t - | Por (i,t1,t2) -> - let s1 = - destructurate_pos_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in - s1 @ s2 - | Pand(i,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations (list_depends) t1 in - let rec loop = function - le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - | Pimp(i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in - s1 @ s2 - -and destructurate_neg_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t - | Pand (i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_neg_hyp orig list_equations (i::list_depends) t2 in - s1 @ s2 - | Por(_,t1,t2) -> - let list_s1 = - destructurate_neg_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - | Pimp(_,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - -let destructurate_hyps syst = - let rec loop = function - (i,t) :: l -> - let l_syst1 = destructurate_pos_hyp i [] [] t in - let l_syst2 = loop l in - list_cartesian (@) l_syst1 l_syst2 - | [] -> [[]] in - loop syst - -(* \subsection{Affichage d'un système d'équation} *) - -(* Affichage des dépendances de système *) -let display_depend = function - Left i -> Printf.printf " L%d" i - | Right i -> Printf.printf " R%d" i - -let display_systems syst_list = - let display_omega om_e = - Printf.printf " E%d : %a %s 0\n" - om_e.id - (fun _ -> display_eq display_omega_var) - (om_e.body, om_e.constant) - (operator_of_eq om_e.kind) in - - let display_equation oformula_eq = - pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); - display_omega oformula_eq.e_omega; - Printf.printf " Depends on:"; - List.iter display_depend oformula_eq.e_depends; - Printf.printf "\n Path: %s" - (String.concat "" - (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") - oformula_eq.e_origin.o_path)); - Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Names.string_of_id oformula_eq.e_origin.o_hyp) - (if oformula_eq.e_negated then "yes" else "no") in - - let display_system syst = - Printf.printf "=SYSTEM===================================\n"; - List.iter display_equation syst in - List.iter display_system syst_list - -(* Extraction des prédicats utilisées dans une trace. Permet ensuite le - calcul des hypothèses *) - -let rec hyps_used_in_trace = function - | act :: l -> - begin match act with - | HYP e -> [e.id] @@ (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @@ hyps_used_in_trace act2 - | _ -> hyps_used_in_trace l - end - | [] -> [] - -(* Extraction des variables déclarées dans une équation. Permet ensuite - de les déclarer dans l'environnement de la procédure réflexive et - éviter les créations de variable au vol *) - -let rec variable_stated_in_trace = function - | act :: l -> - begin match act with - | STATE action -> - (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) - (*i coef: int, var:int i*) - action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - variable_stated_in_trace act1 @ variable_stated_in_trace act2 - | _ -> variable_stated_in_trace l - end - | [] -> [] -;; - -let add_stated_equations env tree = - (* Il faut trier les variables par ordre d'introduction pour ne pas risquer - de définir dans le mauvais ordre *) - let stated_equations = - let cmpvar x y = Pervasives.(-) x.st_var y.st_var in - let rec loop = function - | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) - | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) - in loop tree - in - let add_env st = - (* On retransforme la définition de v en formule reifiée *) - let v_def = oformula_of_omega env st.st_def in - (* Notez que si l'ordre de création des variables n'est pas respecté, - * ca va planter *) - let coq_v = coq_of_formula env v_def in - let v = add_reified_atom coq_v env in - (* Le terme qu'il va falloir introduire *) - let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in - (* sa représentation sous forme d'équation mais non réifié car on n'a pas - * l'environnement pour le faire correctement *) - let term_to_reify = (v_def,Oatom v) in - (* enregistre le lien entre la variable omega et la variable Coq *) - intern_omega_force env (Oatom v) st.st_var; - (v, term_to_generalize,term_to_reify,st.st_def.id) in - List.map add_env stated_equations - -(* Calcule la liste des éclatements à réaliser sur les hypothèses - nécessaires pour extraire une liste d'équations donnée *) - -(* PL: experimentally, the result order of the following function seems - _very_ crucial for efficiency. No idea why. Do not remove the List.rev - or modify the current semantics of Util.list_union (some elements of first - arg, then second arg), unless you know what you're doing. *) - -let rec get_eclatement env = function - i :: r -> - let l = try (get_equation env i).e_depends with Not_found -> [] in - list_union (List.rev l) (get_eclatement env r) - | [] -> [] - -let select_smaller l = - let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in - try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" - -let filter_compatible_systems required systems = - let rec select = function - (x::l) -> - if List.mem x required then select l - else if List.mem (barre x) required then failwith "Exit" - else x :: select l - | [] -> [] in - map_succeed (function (sol,splits) -> (sol,select splits)) systems - -let rec equas_of_solution_tree = function - Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) - | Leaf s -> s.s_equa_deps - -(* [really_useful_prop] pushes useless props in a new Pprop variable *) -(* Things get shorter, but may also get wrong, since a Prop is considered - to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance - Pfalse is decidable. So should not be used on conclusion (??) *) - -let really_useful_prop l_equa c = - let rec real_of = function - Pequa(t,_) -> t - | Ptrue -> app coq_True [||] - | Pfalse -> app coq_False [||] - | Pnot t1 -> app coq_not [|real_of t1|] - | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] - | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] - (* Attention : implications sur le lifting des variables à comprendre ! *) - | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) - | Pprop t -> t in - let rec loop c = - match c with - Pequa(_,e) -> - if List.mem e.e_omega.id l_equa then Some c else None - | Ptrue -> None - | Pfalse -> None - | Pnot t1 -> - begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end - | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 - | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 - | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 - | Pprop t -> None - and binop f t1 t2 = - begin match loop t1, loop t2 with - None, None -> None - | Some t1',Some t2' -> Some (f(t1',t2')) - | Some t1',None -> Some (f(t1',Pprop (real_of t2))) - | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) - end in - match loop c with - None -> Pprop (real_of c) - | Some t -> t - -let rec display_solution_tree ch = function - Leaf t -> - output_string ch - (Printf.sprintf "%d[%s]" - t.s_index - (String.concat " " (List.map string_of_int t.s_equa_deps))) - | Tree(i,t1,t2) -> - Printf.fprintf ch "S%d(%a,%a)" i - display_solution_tree t1 display_solution_tree t2 - -let rec solve_with_constraints all_solutions path = - let rec build_tree sol buf = function - [] -> Leaf sol - | (Left i :: remainder) -> - Tree(i, - build_tree sol (Left i :: buf) remainder, - solve_with_constraints all_solutions (List.rev(Right i :: buf))) - | (Right i :: remainder) -> - Tree(i, - solve_with_constraints all_solutions (List.rev (Left i :: buf)), - build_tree sol (Right i :: buf) remainder) in - let weighted = filter_compatible_systems path all_solutions in - let (winner_sol,winner_deps) = - try select_smaller weighted - with e -> - Printf.printf "%d - %d\n" - (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise e in - build_tree winner_sol (List.rev path) winner_deps - -let find_path {o_hyp=id;o_path=p} env = - let rec loop_path = function - ([],l) -> Some l - | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) - | _ -> None in - let rec loop_id i = function - CCHyp{o_hyp=id';o_path=p'} :: l when id = id' -> - begin match loop_path (p',p) with - Some r -> i,r - | None -> loop_id (succ i) l - end - | _ :: l -> loop_id (succ i) l - | [] -> failwith "find_path" in - loop_id 0 env - -let mk_direction_list l = - let trans = function - O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in - mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) - - -(* \section{Rejouer l'historique} *) - -let get_hyp env_hyp i = - try list_index0 (CCEqua i) env_hyp - with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) - -let replay_history env env_hyp = - let rec loop env_hyp t = - match t with - | CONTRADICTION (e1,e2) :: l -> - let trace = mk_nat (List.length e1.body) in - mkApp (Lazy.force coq_s_contradiction, - [| trace ; mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - mkApp (Lazy.force coq_s_div_approx, - [| Z.mk k; Z.mk d; - reified_of_omega env e2.body e2.constant; - mk_nat (List.length e2.body); - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let e2_constant = floor_div e1.constant k in - let d = e1.constant - e2_constant * k in - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - mkApp (Lazy.force coq_s_not_exact_divide, - [|Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); - mk_nat (get_hyp env_hyp e1.id)|]) - | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = - map_eq_linear (fun c -> c / k) e1.body in - let e2_constant = floor_div e1.constant k in - mkApp (Lazy.force coq_s_exact_divide, - [|Z.mk k; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) - | (MERGE_EQ(e3,e1,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in - mkApp (Lazy.force coq_s_merge_eq, - [| mk_nat (List.length e1.body); - mk_nat n1; mk_nat n2; - loop (CCEqua e3:: env_hyp) l |]) - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id - and n2 = get_hyp env_hyp e2.id in - let trace = shuffle_path k1 e1.body k2 e2.body in - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; mk_nat n1; Z.mk k2; - mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) - | CONSTANT_NOT_NUL(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_not_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | CONSTANT_NEG(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_neg, - [| mk_nat (get_hyp env_hyp e) |]) - | STATE {st_new_eq=new_eq; st_def =def; - st_orig=orig; st_coef=m; - st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id - and n2 = get_hyp env_hyp def.id in - let v = unintern_omega env sigma in - let o_def = oformula_of_omega env def in - let o_orig = oformula_of_omega env orig in - let body = - Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in - let trace,_ = normalize_linear_term env body in - mkApp (Lazy.force coq_s_state, - [| Z.mk m; trace; mk_nat n1; mk_nat n2; - loop (CCEqua new_eq.id :: env_hyp) l |]) - | HYP _ :: l -> loop env_hyp l - | CONSTANT_NUL e :: l -> - mkApp (Lazy.force coq_s_constant_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | NEGATE_CONTRADICT(e1,e2,true) :: l -> - mkApp (Lazy.force coq_s_negate_contradict, - [| mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | NEGATE_CONTRADICT(e1,e2,false) :: l -> - mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (List.length e2.body); - mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> - let i = get_hyp env_hyp e.id in - let r1 = loop (CCEqua e1 :: env_hyp) l1 in - let r2 = loop (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, - [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) - | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> - loop env_hyp l - | (WEAKEN _ ) :: l -> failwith "not_treated" - | [] -> failwith "no contradiction" - in loop env_hyp - -let rec decompose_tree env ctxt = function - Tree(i,left,right) -> - let org = - try Hashtbl.find env.constructors i - with Not_found -> - failwith (Printf.sprintf "Cannot find constructor %d" i) in - let (index,path) = find_path org ctxt in - let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in - let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in - app coq_e_split - [| mk_nat index; - mk_direction_list path; - decompose_tree env (left_hyp::ctxt) left; - decompose_tree env (right_hyp::ctxt) right |] - | Leaf s -> - decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps -and decompose_tree_hyps trace env ctxt = function - [] -> app coq_e_solve [| replay_history env ctxt trace |] - | (i::l) -> - let equation = - try Hashtbl.find env.equations i - with Not_found -> - failwith (Printf.sprintf "Cannot find equation %d" i) in - let (index,path) = find_path equation.e_origin ctxt in - let full_path = if equation.e_negated then path @ [O_mono] else path in - let cont = - decompose_tree_hyps trace env - (CCEqua equation.e_omega.id :: ctxt) l in - app coq_e_extract [|mk_nat index; - mk_direction_list full_path; - cont |] - -(* \section{La fonction principale} *) - (* Cette fonction construit la -trace pour la procédure de décision réflexive. A partir des résultats -de l'extraction des systèmes, elle lance la résolution par Omega, puis -l'extraction d'un ensemble minimal de solutions permettant la -résolution globale du système et enfin construit la trace qui permet -de faire rejouer cette solution par la tactique réflexive. *) - -let resolution env full_reified_goal systems_list = - let num = ref 0 in - let solve_system list_eq = - let index = !num in - let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system in - (* calcule les hypotheses utilisées pour la solution *) - let vars = hyps_used_in_trace trace in - let splits = get_eclatement env vars in - if !debug then begin - Printf.printf "SYSTEME %d\n" index; - display_action display_omega_var trace; - print_string "\n Depend :"; - List.iter (fun i -> Printf.printf " %d" i) vars; - print_string "\n Split points :"; - List.iter display_depend splits; - Printf.printf "\n------------------------------------\n" - end; - incr num; - {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in - if !debug then Printf.printf "\n====================================\n"; - let all_solutions = List.map solve_system systems_list in - let solution_tree = solve_with_constraints all_solutions [] in - if !debug then begin - display_solution_tree stdout solution_tree; - print_newline() - end; - (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) - let useful_equa_id = equas_of_solution_tree solution_tree in - (* recupere explicitement ces equations *) - let equations = List.map (get_equation env) useful_equa_id in - let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in - let l_hyps = id_concl :: list_remove id_concl l_hyps' in - let useful_hyps = - List.map (fun id -> List.assoc id full_reified_goal) l_hyps in - let useful_vars = - let really_useful_vars = vars_of_equations equations in - let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in - really_useful_vars @@ concl_vars - in - (* variables a introduire *) - let to_introduce = add_stated_equations env solution_tree in - let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in - let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in - let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in - (* L'environnement de base se construit en deux morceaux : - - les variables des équations utiles (et de la conclusion) - - les nouvelles variables declarées durant les preuves *) - let all_vars_env = useful_vars @ stated_vars in - let basic_env = - let rec loop i = function - var :: l -> - let t = get_reified_atom env var in - Hashtbl.add env.real_indices var i; t :: loop (succ i) l - | [] -> [] in - loop 0 all_vars_env in - let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in - (* On peut maintenant généraliser le but : env est a jour *) - let l_reified_stated = - List.map (fun (_,_,(l,r),_) -> - app coq_p_eq [| reified_of_formula env l; - reified_of_formula env r |]) - to_introduce in - let reified_concl = - match useful_hyps with - (Pnot p) :: _ -> reified_of_proposition env p - | _ -> reified_of_proposition env Pfalse in - let l_reified_terms = - (List.map - (fun p -> - reified_of_proposition env (really_useful_prop useful_equa_id p)) - (List.tl useful_hyps)) in - let env_props_reified = mk_plist env.props in - let reified_goal = - mk_list (Lazy.force coq_proposition) - (l_reified_stated @ l_reified_terms) in - let reified = - app coq_interp_sequent - [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in - let normalize_equation e = - let rec loop = function - [] -> app (if e.e_negated then coq_p_invert else coq_p_step) - [| e.e_trace |] - | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] - | (O_right :: l) -> app coq_p_right [| loop l |] in - let correct_index = - let i = list_index0 e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionnally introduced hyps are in the way during - normalization, hence this index shifting... *) - if i=0 then 0 else Pervasives.(+) i (List.length to_introduce) - in - app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in - let normalization_trace = - mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in - - let initial_context = - List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in - let context = - CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in - let decompose_tactic = decompose_tree env context solution_tree in - - Tactics.generalize - (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> - Tactics.change_in_concl None reified >> - Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> - show_goal >> - Tactics.normalise_vm_in_concl >> - (*i Alternatives to the previous line: - - Normalisation without VM: - Tactics.normalise_in_concl - - Skip the conversion check and rely directly on the QED: - Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> - i*) - Tactics.apply (Lazy.force coq_I) - -let total_reflexive_omega_tactic gl = - Coqlib.check_required_library ["Coq";"romega";"ROmega"]; - rst_omega_eq (); - rst_omega_var (); - try - let env = new_environment () in - let full_reified_goal = reify_gl env gl in - let systems_list = destructurate_hyps full_reified_goal in - if !debug then display_systems systems_list; - resolution env full_reified_goal systems_list gl - with NO_CONTRADICTION -> Util.error "ROmega can't solve this system" - - -(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) - - diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v deleted file mode 100644 index e90fea84..00000000 --- a/contrib/rtauto/Bintree.v +++ /dev/null @@ -1,489 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *) - -Require Export List. -Require Export BinPos. - -Unset Boxed Definitions. - -Open Scope positive_scope. - -Ltac clean := try (simpl; congruence). -Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. - -Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. - -Lemma Gt_Eq_Gt : forall p q cmp, - (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); -simpl;auto;congruence. -Qed. - -Lemma Gt_Lt_Gt : forall p q cmp, - (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt)); -simpl;auto;congruence. -Qed. - -Lemma Gt_Psucc_Eq: forall p q, - (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -intro;apply Gt_Eq_Gt;auto. -apply Gt_Lt_Gt. -Qed. - -Lemma Eq_Psucc_Gt: forall p q, - (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -intro H;elim (Pcompare_not_Eq p (Psucc q));tauto. -intro H;apply Gt_Eq_Gt;auto. -intro H;rewrite Pcompare_Eq_eq with p q;auto. -generalize q;clear q IHq p H;induction q;simpl;auto. -intro H;elim (Pcompare_not_Eq p q);tauto. -Qed. - -Lemma Gt_Psucc_Gt : forall n p cmp cmp0, - (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt. -induction n;intros [ | p | p];simpl;try congruence. -intros; apply IHn with cmp;trivial. -intros; apply IHn with Gt;trivial. -intros;apply Gt_Lt_Gt;trivial. -intros [ | | ] _ H. -apply Gt_Eq_Gt;trivial. -apply Gt_Lt_Gt;trivial. -trivial. -Qed. - -Lemma Gt_Psucc: forall p q, - (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -apply Gt_Psucc_Eq. -intro;apply Gt_Eq_Gt;apply IHq;auto. -apply Gt_Eq_Gt. -apply Gt_Lt_Gt. -Qed. - -Lemma Psucc_Gt : forall p, - (Psucc p ?= p) Eq = Gt. -induction p;simpl. -apply Gt_Eq_Gt;auto. -generalize p;clear p IHp. -induction p;simpl;auto. -reflexivity. -Qed. - -Fixpoint pos_eq (m n:positive) {struct m} :bool := -match m, n with - xI mm, xI nn => pos_eq mm nn -| xO mm, xO nn => pos_eq mm nn -| xH, xH => true -| _, _ => false -end. - -Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. -induction m;simpl;intro n;destruct n;congruence || -(intro e;apply f_equal with positive;auto). -Defined. - -Theorem refl_pos_eq : forall m, pos_eq m m = true. -induction m;simpl;auto. -Qed. - -Definition pos_eq_dec (m n:positive) :{m=n}+{m<>n} . -fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence). -case (pos_eq_dec mm nn). -intro e;left;apply (f_equal xI e). -intro ne;right;congruence. -case (pos_eq_dec mm nn). -intro e;left;apply (f_equal xO e). -intro ne;right;congruence. -left;reflexivity. -Defined. - -Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m). -fix 1;intros [mm|mm|]. -simpl; rewrite pos_eq_dec_refl; reflexivity. -simpl; rewrite pos_eq_dec_refl; reflexivity. -reflexivity. -Qed. - -Theorem pos_eq_dec_ex : forall m n, - pos_eq m n =true -> exists h:m=n, - pos_eq_dec m n = left _ h. -fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). -simpl;intro e. -elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. -exists (f_equal xI x). -reflexivity. -simpl;intro e. -elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. -exists (f_equal xO x). -reflexivity. -simpl. -exists (refl_equal xH). -reflexivity. -Qed. - -Fixpoint nat_eq (m n:nat) {struct m}: bool:= -match m, n with -O,O => true -| S mm,S nn => nat_eq mm nn -| _,_ => false -end. - -Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n. -induction m;simpl;intro n;destruct n;congruence || -(intro e;apply f_equal with nat;auto). -Defined. - -Theorem refl_nat_eq : forall n, nat_eq n n = true. -induction n;simpl;trivial. -Defined. - -Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := -match l with nil => None -| x::q => -match n with O => Some x -| S m => Lget A m q -end end . - -Implicit Arguments Lget [A]. - -Lemma map_app : forall (A B:Set) (f:A -> B) l m, -List.map f (l ++ m) = List.map f l ++ List.map f m. -induction l. -reflexivity. -simpl. -intro m ; apply f_equal with (list B);apply IHl. -Qed. - -Lemma length_map : forall (A B:Set) (f:A -> B) l, -length (List.map f l) = length l. -induction l. -reflexivity. -simpl; apply f_equal with nat;apply IHl. -Qed. - -Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, -Lget i (List.map f l) = -match Lget i l with Some a => -Some (f a) | None => None end. -induction i;intros [ | x l ] ;trivial. -simpl;auto. -Qed. - -Lemma Lget_app : forall (A:Set) (a:A) l i, -Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l. -induction l;simpl Lget;simpl length. -intros [ | i];simpl;reflexivity. -intros [ | i];simpl. -reflexivity. -auto. -Qed. - -Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), -Lget i l = Some a -> -Lget i (l ++ delta) = Some a. -induction l;destruct i;simpl;try congruence;auto. -Qed. - -Section Store. - -Variable A:Type. - -Inductive Poption : Type:= - PSome : A -> Poption -| PNone : Poption. - -Inductive Tree : Type := - Tempty : Tree - | Branch0 : Tree -> Tree -> Tree - | Branch1 : A -> Tree -> Tree -> Tree. - -Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := - match T with - Tempty => PNone - | Branch0 T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PNone - end - | Branch1 a T1 T2 => - match p with - xI pp => Tget pp T2 - | xO pp => Tget pp T1 - | xH => PSome a - end -end. - -Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := - match T with - | Tempty => - match p with - | xI pp => Branch0 Tempty (Tadd pp a Tempty) - | xO pp => Branch0 (Tadd pp a Tempty) Tempty - | xH => Branch1 a Tempty Tempty - end - | Branch0 T1 T2 => - match p with - | xI pp => Branch0 T1 (Tadd pp a T2) - | xO pp => Branch0 (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tadd pp a T2) - | xO pp => Branch1 b (Tadd pp a T1) T2 - | xH => Branch1 a T1 T2 - end - end. - -Definition mkBranch0 (T1 T2:Tree) := - match T1,T2 with - Tempty ,Tempty => Tempty - | _,_ => Branch0 T1 T2 - end. - -Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := - match T with - | Tempty => Tempty - | Branch0 T1 T2 => - match p with - | xI pp => mkBranch0 T1 (Tremove pp T2) - | xO pp => mkBranch0 (Tremove pp T1) T2 - | xH => T - end - | Branch1 b T1 T2 => - match p with - | xI pp => Branch1 b T1 (Tremove pp T2) - | xO pp => Branch1 b (Tremove pp T1) T2 - | xH => mkBranch0 T1 T2 - end - end. - - -Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. -destruct p;reflexivity. -Qed. - -Theorem Tget_Tadd: forall i j a T, - Tget i (Tadd j a T) = - match (i ?= j) Eq with - Eq => PSome a - | Lt => Tget i T - | Gt => Tget i T - end. -intros i j. -caseq ((i ?= j) Eq). -intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H. -induction j;destruct T;simpl;try (apply IHj);congruence. -generalize i;clear i;induction j;destruct T;simpl in H|-*; -destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -generalize i;clear i;induction j;destruct T;simpl in H|-*; -destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. -Qed. - -Record Store : Type := -mkStore {index:positive;contents:Tree}. - -Definition empty := mkStore xH Tempty. - -Definition push a S := -mkStore (Psucc (index S)) (Tadd (index S) a (contents S)). - -Definition get i S := Tget i (contents S). - -Lemma get_empty : forall i, get i empty = PNone. -intro i; case i; unfold empty,get; simpl;reflexivity. -Qed. - -Inductive Full : Store -> Type:= - F_empty : Full empty - | F_push : forall a S, Full S -> Full (push a S). - -Theorem get_Full_Gt : forall S, Full S -> - forall i, (i ?= index S) Eq = Gt -> get i S = PNone. -intros S W;induction W. -unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. -intros i e;rewrite Tget_Tadd. -rewrite (Gt_Psucc _ _ e). -unfold get in IHW. -apply IHW;apply Gt_Psucc;assumption. -Qed. - -Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone. -intros [index0 contents0] F. -case F. -unfold empty,index,get,contents;intros;apply Tget_Tempty. -unfold index,get,push;simpl contents. -intros a S. -rewrite Tget_Tadd. -rewrite Psucc_Gt. -intro W. -change (get (Psucc (index S)) S =PNone). -apply get_Full_Gt; auto. -apply Psucc_Gt. -Qed. - -Theorem get_push_Full : - forall i a S, Full S -> - get i (push a S) = - match (i ?= index S) Eq with - Eq => PSome a - | Lt => get i S - | Gt => PNone -end. -intros i a S F. -caseq ((i ?= index S) Eq). -intro e;rewrite (Pcompare_Eq_eq _ _ e). -destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -rewrite Pcompare_refl;reflexivity. -intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -simpl index in H;rewrite H;reflexivity. -intro H;generalize H;clear H. -unfold get,push;simpl index;simpl contents. -rewrite Tget_Tadd;intro e;rewrite e. -change (get i S=PNone). -apply get_Full_Gt;auto. -Qed. - -Lemma Full_push_compat : forall i a S, Full S -> -forall x, get i S = PSome x -> - get i (push a S) = PSome x. -intros i a S F x H. -caseq ((i ?= index S) Eq);intro test. -rewrite (Pcompare_Eq_eq _ _ test) in H. -rewrite (get_Full_Eq _ F) in H;congruence. -rewrite <- H. -rewrite (get_push_Full i a). -rewrite test;reflexivity. -assumption. -rewrite (get_Full_Gt _ F) in H;congruence. -Qed. - -Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. -intros [ind cont] F one; inversion F. -reflexivity. -simpl index in one;assert (h:=Psucc_not_one (index S)). -congruence. -Qed. - -Lemma push_not_empty: forall a S, (push a S) <> empty. -intros a [ind cont];unfold push,empty. -simpl;intro H;injection H; intros _ ; apply Psucc_not_one. -Qed. - -Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := -match F with -F_empty => False -| F_push a SS FF => x=a \/ In x SS FF -end. - -Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , -get i S = PSome x -> In x S F. -induction F. -intro i;rewrite get_empty; congruence. -intro i;rewrite get_push_Full;trivial. -caseq ((i ?= index S) Eq);simpl. -left;congruence. -right;eauto. -congruence. -Qed. - -End Store. - -Implicit Arguments PNone [A]. -Implicit Arguments PSome [A]. - -Implicit Arguments Tempty [A]. -Implicit Arguments Branch0 [A]. -Implicit Arguments Branch1 [A]. - -Implicit Arguments Tget [A]. -Implicit Arguments Tadd [A]. - -Implicit Arguments Tget_Tempty [A]. -Implicit Arguments Tget_Tadd [A]. - -Implicit Arguments mkStore [A]. -Implicit Arguments index [A]. -Implicit Arguments contents [A]. - -Implicit Arguments empty [A]. -Implicit Arguments get [A]. -Implicit Arguments push [A]. - -Implicit Arguments get_empty [A]. -Implicit Arguments get_push_Full [A]. - -Implicit Arguments Full [A]. -Implicit Arguments F_empty [A]. -Implicit Arguments F_push [A]. -Implicit Arguments In [A]. - -Section Map. - -Variables A B:Set. - -Variable f: A -> B. - -Fixpoint Tmap (T: Tree A) : Tree B := -match T with -Tempty => Tempty -| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2) -| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) -end. - -Lemma Tget_Tmap: forall T i, -Tget i (Tmap T)= match Tget i T with PNone => PNone -| PSome a => PSome (f a) end. -induction T;intro i;case i;simpl;auto. -Defined. - -Lemma Tmap_Tadd: forall i a T, -Tmap (Tadd i a T) = Tadd i (f a) (Tmap T). -induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity. -Defined. - -Definition map (S:Store A) : Store B := -mkStore (index S) (Tmap (contents S)). - -Lemma get_map: forall i S, -get i (map S)= match get i S with PNone => PNone -| PSome a => PSome (f a) end. -destruct S;unfold get,map,contents,index;apply Tget_Tmap. -Defined. - -Lemma map_push: forall a S, -map (push a S) = push (f a) (map S). -intros a S. -case S. -unfold push,map,contents,index. -intros;rewrite Tmap_Tadd;reflexivity. -Defined. - -Theorem Full_map : forall S, Full S -> Full (map S). -intros S F. -induction F. -exact F_empty. -rewrite map_push;constructor 2;assumption. -Defined. - -End Map. - -Implicit Arguments Tmap [A B]. -Implicit Arguments map [A B]. -Implicit Arguments Full_map [A B f]. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). diff --git a/contrib/rtauto/Rtauto.v b/contrib/rtauto/Rtauto.v deleted file mode 100644 index 98fca90f..00000000 --- a/contrib/rtauto/Rtauto.v +++ /dev/null @@ -1,398 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: Rtauto.v 7639 2005-12-02 10:01:15Z gregoire $ *) - - -Require Export List. -Require Export Bintree. -Require Import Bool. -Unset Boxed Definitions. - -Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. -Ltac clean:=try (simpl;congruence). - -Inductive form:Set:= - Atom : positive -> form -| Arrow : form -> form -> form -| Bot -| Conjunct : form -> form -> form -| Disjunct : form -> form -> form. - -Notation "[ n ]":=(Atom n). -Notation "A =>> B":= (Arrow A B) (at level 59, right associativity). -Notation "#" := Bot. -Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity). -Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity). - -Definition ctx := Store form. - -Fixpoint pos_eq (m n:positive) {struct m} :bool := -match m with - xI mm => match n with xI nn => pos_eq mm nn | _ => false end -| xO mm => match n with xO nn => pos_eq mm nn | _ => false end -| xH => match n with xH => true | _ => false end -end. - -Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. -induction m;simpl;destruct n;congruence || -(intro e;apply f_equal with positive;auto). -Qed. - -Fixpoint form_eq (p q:form) {struct p} :bool := -match p with - Atom m => match q with Atom n => pos_eq m n | _ => false end -| Arrow p1 p2 => -match q with - Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false end -| Bot => match q with Bot => true | _ => false end -| Conjunct p1 p2 => -match q with - Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -| Disjunct p1 p2 => -match q with - Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false -end -end. - -Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. -induction p;destruct q;simpl;clean. -intro h;generalize (pos_eq_refl _ _ h);congruence. -caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -Qed. - -Implicit Arguments form_eq_refl [p q]. - -Section with_env. - -Variable env:Store Prop. - -Fixpoint interp_form (f:form): Prop := -match f with -[n]=> match get n env with PNone => True | PSome P => P end -| A =>> B => (interp_form A) -> (interp_form B) -| # => False -| A //\\ B => (interp_form A) /\ (interp_form B) -| A \\// B => (interp_form A) \/ (interp_form B) -end. - -Notation "[[ A ]]" := (interp_form A). - -Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop := -match F with - F_empty => G -| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G) -end. - -Require Export BinPos. - -Ltac wipe := intros;simpl;constructor. - -Lemma compose0 : -forall hyps F (A:Prop), - A -> - (interp_ctx hyps F A). -induction F;intros A H;simpl;auto. -Qed. - -Lemma compose1 : -forall hyps F (A B:Prop), - (A -> B) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B). -induction F;intros A B H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose2 : -forall hyps F (A B C:Prop), - (A -> B -> C) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C). -induction F;intros A B C H;simpl;auto. -apply IHF;auto. -Qed. - -Theorem compose3 : -forall hyps F (A B C D:Prop), - (A -> B -> C -> D) -> - (interp_ctx hyps F A) -> - (interp_ctx hyps F B) -> - (interp_ctx hyps F C) -> - (interp_ctx hyps F D). -induction F;intros A B C D H;simpl;auto. -apply IHF;auto. -Qed. - -Lemma weaken : forall hyps F f G, - (interp_ctx hyps F G) -> - (interp_ctx (hyps\f) (F_push f hyps F) G). -induction F;simpl;intros;auto. -apply compose1 with ([[a]]-> G);auto. -Qed. - -Theorem project_In : forall hyps F g, -In g hyps F -> -interp_ctx hyps F [[g]]. -induction F;simpl. -contradiction. -intros g H;destruct H. -subst;apply compose0;simpl;trivial. -apply compose1 with [[g]];auto. -Qed. - -Theorem project : forall hyps F p g, -get p hyps = PSome g-> -interp_ctx hyps F [[g]]. -intros hyps F p g e; apply project_In. -apply get_In with p;assumption. -Qed. - -Implicit Arguments project [hyps p g]. - -Inductive proof:Set := - Ax : positive -> proof -| I_Arrow : proof -> proof -| E_Arrow : positive -> positive -> proof -> proof -| D_Arrow : positive -> proof -> proof -> proof -| E_False : positive -> proof -| I_And: proof -> proof -> proof -| E_And: positive -> proof -> proof -| D_And: positive -> proof -> proof -| I_Or_l: proof -> proof -| I_Or_r: proof -> proof -| E_Or: positive -> proof -> proof -> proof -| D_Or: positive -> proof -> proof -| Cut: form -> proof -> proof -> proof. - -Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). - -Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := - match P with - Ax i => - match get i hyps with - PSome F => form_eq F gl - | _ => false - end -| I_Arrow p => - match gl with - A =>> B => check_proof (hyps \ A) B p - | _ => false - end -| E_Arrow i j p => - match get i hyps,get j hyps with - PSome A,PSome (B =>>C) => - form_eq A B && check_proof (hyps \ C) (gl) p - | _,_ => false - end -| D_Arrow i p1 p2 => - match get i hyps with - PSome ((A =>>B)=>>C) => - (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) - | _ => false - end -| E_False i => - match get i hyps with - PSome # => true - | _ => false - end -| I_And p1 p2 => - match gl with - A //\\ B => - check_proof hyps A p1 && check_proof hyps B p2 - | _ => false - end -| E_And i p => - match get i hyps with - PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p - | _=> false - end -| D_And i p => - match get i hyps with - PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p - | _=> false - end -| I_Or_l p => - match gl with - (A \\// B) => check_proof hyps A p - | _ => false - end -| I_Or_r p => - match gl with - (A \\// B) => check_proof hyps B p - | _ => false - end -| E_Or i p1 p2 => - match get i hyps with - PSome (A \\// B) => - check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 - | _=> false - end -| D_Or i p => - match get i hyps with - PSome (A \\// B =>> C) => - (check_proof (hyps \ A=>>C \ B=>>C) gl p) - | _=> false - end -| Cut A p1 p2 => - check_proof hyps A p1 && check_proof (hyps \ A) gl p2 -end. - -Theorem interp_proof: -forall p hyps F gl, -check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. - -induction p;intros hyps F gl. - -(* cas Axiom *) -Focus 1. -simpl;caseq (get p hyps);clean. -intros f nth_f e;rewrite <- (form_eq_refl e). -apply project with p;trivial. - -(* Cas Arrow_Intro *) -Focus 1. -destruct gl;clean. -simpl;intros. -change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]). -apply IHp;try constructor;trivial. - -(* Cas Arrow_Elim *) -Focus 1. -simpl check_proof;caseq (get p hyps);clean. -intros f ef;caseq (get p0 hyps);clean. -intros f0 ef0;destruct f0;clean. -caseq (form_eq f f0_1);clean. -simpl;intros e check_p1. -generalize (project F ef) (project F ef0) -(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); -clear check_p1 IHp p p0 p1 ef ef0. -simpl. -apply compose3. -rewrite (form_eq_refl e). -auto. - -(* cas Arrow_Destruct *) -Focus 1. -simpl;caseq (get p1 hyps);clean. -intros f ef;destruct f;clean. -destruct f1;clean. -caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. -intros check_p1 check_p2. -generalize (project F ef) -(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) -(F_push f1_1 (hyps \ f1_2 =>> f2) - (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) -(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). -simpl;apply compose3;auto. - -(* Cas False_Elim *) -Focus 1. -simpl;caseq (get p hyps);clean. -intros f ef;destruct f;clean. -intros _; generalize (project F ef). -apply compose1;apply False_ind. - -(* Cas And_Intro *) -Focus 1. -simpl;destruct gl;clean. -caseq (check_proof hyps gl1 p1);clean. -intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). -apply compose2 ;simpl;auto. - -(* cas And_Elim *) -Focus 1. -simpl;caseq (get p hyps);clean. -intros f ef;destruct f;clean. -intro check_p;generalize (project F ef) -(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). -simpl;apply compose2;intros [h1 h2];auto. - -(* cas And_Destruct *) -Focus 1. -simpl;caseq (get p hyps);clean. -intros f ef;destruct f;clean. -destruct f1;clean. -intro H;generalize (project F ef) -(IHp (hyps \ f1_1 =>> f1_2 =>> f2) -(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. -apply compose2;auto. - -(* cas Or_Intro_left *) -Focus 1. -destruct gl;clean. -intro Hp;generalize (IHp hyps F gl1 Hp). -apply compose1;simpl;auto. - -(* cas Or_Intro_right *) -Focus 1. -destruct gl;clean. -intro Hp;generalize (IHp hyps F gl2 Hp). -apply compose1;simpl;auto. - -(* cas Or_elim *) -Focus 1. -simpl;caseq (get p1 hyps);clean. -intros f ef;destruct f;clean. -caseq (check_proof (hyps \ f1) gl p2);clean. -intros check_p1 check_p2;generalize (project F ef) -(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) -(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); -simpl;apply compose3;simpl;intro h;destruct h;auto. - -(* cas Or_Destruct *) -Focus 1. -simpl;caseq (get p hyps);clean. -intros f ef;destruct f;clean. -destruct f1;clean. -intro check_p0;generalize (project F ef) -(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) -(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) - (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. -apply compose2;auto. - -(* cas Cut *) -Focus 1. -simpl;caseq (check_proof hyps f p1);clean. -intros check_p1 check_p2; -generalize (IHp1 hyps F f check_p1) -(IHp2 (hyps\f) (F_push f hyps F) gl check_p2); -simpl; apply compose2;auto. -Qed. - -Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. -intros gl prf;caseq (check_proof empty gl prf);intro check_prf. -change (interp_ctx empty F_empty [[gl]]) ; -apply interp_proof with prf;assumption. -trivial. -Qed. - -End with_env. - -(* -(* A small example *) -Parameters A B C D:Prop. -Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). -exact (Reflect (empty \ A \ B \ C) -([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) -(I_Arrow (E_And 1 (E_Or 3 - (I_Or_l (I_And (Ax 2) (Ax 4))) - (I_Or_r (I_And (Ax 2) (Ax 4))))))). -Qed. -Print toto. -*) diff --git a/contrib/rtauto/g_rtauto.ml4 b/contrib/rtauto/g_rtauto.ml4 deleted file mode 100644 index d7bb6e31..00000000 --- a/contrib/rtauto/g_rtauto.ml4 +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -TACTIC EXTEND rtauto - [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ] -END - diff --git a/contrib/rtauto/proof_search.ml b/contrib/rtauto/proof_search.ml deleted file mode 100644 index 98643e0f..00000000 --- a/contrib/rtauto/proof_search.ml +++ /dev/null @@ -1,546 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: proof_search.ml 7233 2005-07-15 12:34:56Z corbinea $ *) - -open Term -open Util -open Goptions - -type s_info= - {mutable created_steps : int; (* node count*) - mutable pruned_steps : int; - mutable created_branches : int; (* path count *) - mutable pruned_branches : int; - mutable created_hyps : int; (* hyps count *) - mutable pruned_hyps : int; - mutable branch_failures : int; - mutable branch_successes : int; - mutable nd_branching : int} - -let s_info= - {created_steps = 0; (* node count*) - pruned_steps = 0; - created_branches = 0; (* path count *) - pruned_branches = 0; - created_hyps = 0; (* hyps count *) - pruned_hyps = 0; - branch_failures = 0; - branch_successes = 0; - nd_branching = 0} - -let reset_info () = - s_info.created_steps <- 0; (* node count*) - s_info.pruned_steps <- 0; - s_info.created_branches <- 0; (* path count *) - s_info.pruned_branches <- 0; - s_info.created_hyps <- 0; (* hyps count *) - s_info.pruned_hyps <- 0; - s_info.branch_failures <- 0; - s_info.branch_successes <- 0; - s_info.nd_branching <- 0 - -let pruning = ref true - -let opt_pruning= - {optsync=true; - optname="Rtauto Pruning"; - optkey=SecondaryTable("Rtauto","Pruning"); - optread=(fun () -> !pruning); - optwrite=(fun b -> pruning:=b)} - -let _ = declare_bool_option opt_pruning - -type form= - Atom of int - | Arrow of form * form - | Bot - | Conjunct of form * form - | Disjunct of form * form - -type tag=int - -let decomp_form=function - Atom i -> Some (i,[]) - | Arrow (f1,f2) -> Some (-1,[f1;f2]) - | Bot -> Some (-2,[]) - | Conjunct (f1,f2) -> Some (-3,[f1;f2]) - | Disjunct (f1,f2) -> Some (-4,[f1;f2]) - -module Fmap=Map.Make(struct type t=form let compare=compare end) - -type sequent = - {rev_hyps: form Intmap.t; - norev_hyps: form Intmap.t; - size:int; - left:int Fmap.t; - right:(int*form) list Fmap.t; - cnx:(int*int*form*form) list; - abs:int option; - gl:form} - -let add_one_arrow i f1 f2 m= - try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with - Not_found -> - Fmap.add f1 [i,f2] m - -type proof = - Ax of int - | I_Arrow of proof - | E_Arrow of int*int*proof - | D_Arrow of int*proof*proof - | E_False of int - | I_And of proof*proof - | E_And of int*proof - | D_And of int*proof - | I_Or_l of proof - | I_Or_r of proof - | E_Or of int*proof*proof - | D_Or of int*proof - | Pop of int*proof - -type rule = - SAx of int - | SI_Arrow - | SE_Arrow of int*int - | SD_Arrow of int - | SE_False of int - | SI_And - | SE_And of int - | SD_And of int - | SI_Or_l - | SI_Or_r - | SE_Or of int - | SD_Or of int - -let add_step s sub = - match s,sub with - SAx i,[] -> Ax i - | SI_Arrow,[p] -> I_Arrow p - | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p) - | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2) - | SE_False i,[] -> E_False i - | SI_And,[p1;p2] -> I_And(p1,p2) - | SE_And i,[p] -> E_And(i,p) - | SD_And i,[p] -> D_And(i,p) - | SI_Or_l,[p] -> I_Or_l p - | SI_Or_r,[p] -> I_Or_r p - | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) - | SD_Or i,[p] -> D_Or(i,p) - | _,_ -> anomaly "add_step: wrong arity" - -type 'a with_deps = - {dep_it:'a; - dep_goal:bool; - dep_hyps:Intset.t} - -type slice= - {proofs_done:proof list; - proofs_todo:sequent with_deps list; - step:rule; - needs_goal:bool; - needs_hyps:Intset.t; - changes_goal:bool; - creates_hyps:Intset.t} - -type state = - Complete of proof - | Incomplete of sequent * slice list - -let project = function - Complete prf -> prf - | Incomplete (_,_) -> anomaly "not a successful state" - -let pop n prf = - let nprf= - match prf.dep_it with - Pop (i,p) -> Pop (i+n,p) - | p -> Pop(n,p) in - {prf with dep_it = nprf} - -let rec fill stack proof = - match stack with - [] -> Complete proof.dep_it - | slice::super -> - if - !pruning && - slice.proofs_done=[] && - not (slice.changes_goal && proof.dep_goal) && - not (Intset.exists - (fun i -> Intset.mem i proof.dep_hyps) - slice.creates_hyps) - then - begin - s_info.pruned_steps<-s_info.pruned_steps+1; - s_info.pruned_branches<- s_info.pruned_branches + - List.length slice.proofs_todo; - let created_here=Intset.cardinal slice.creates_hyps in - s_info.pruned_hyps<-s_info.pruned_hyps+ - List.fold_left - (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) - created_here slice.proofs_todo; - fill super (pop (Intset.cardinal slice.creates_hyps) proof) - end - else - let dep_hyps= - Intset.union slice.needs_hyps - (Intset.diff proof.dep_hyps slice.creates_hyps) in - let dep_goal= - slice.needs_goal || - ((not slice.changes_goal) && proof.dep_goal) in - let proofs_done= - proof.dep_it::slice.proofs_done in - match slice.proofs_todo with - [] -> - fill super {dep_it = - add_step slice.step (List.rev proofs_done); - dep_goal = dep_goal; - dep_hyps = dep_hyps} - | current::next -> - let nslice= - {proofs_done=proofs_done; - proofs_todo=next; - step=slice.step; - needs_goal=dep_goal; - needs_hyps=dep_hyps; - changes_goal=current.dep_goal; - creates_hyps=current.dep_hyps} in - Incomplete (current.dep_it,nslice::super) - -let append stack (step,subgoals) = - s_info.created_steps<-s_info.created_steps+1; - match subgoals with - [] -> - s_info.branch_successes<-s_info.branch_successes+1; - fill stack {dep_it=add_step step.dep_it []; - dep_goal=step.dep_goal; - dep_hyps=step.dep_hyps} - | hd :: next -> - s_info.created_branches<- - s_info.created_branches+List.length next; - let slice= - {proofs_done=[]; - proofs_todo=next; - step=step.dep_it; - needs_goal=step.dep_goal; - needs_hyps=step.dep_hyps; - changes_goal=hd.dep_goal; - creates_hyps=hd.dep_hyps} in - Incomplete(hd.dep_it,slice::stack) - -let embed seq= - {dep_it=seq; - dep_goal=false; - dep_hyps=Intset.empty} - -let change_goal seq gl= - {seq with - dep_it={seq.dep_it with gl=gl}; - dep_goal=true} - -let add_hyp seqwd f= - s_info.created_hyps<-s_info.created_hyps+1; - let seq=seqwd.dep_it in - let num = seq.size+1 in - let left = Fmap.add f num seq.left in - let cnx,right= - try - let l=Fmap.find f seq.right in - List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, - Fmap.remove f seq.right - with Not_found -> seq.cnx,seq.right in - let nseq= - match f with - Bot -> - {seq with - left=left; - right=right; - size=num; - abs=Some num; - cnx=cnx} - | Atom _ -> - {seq with - size=num; - left=left; - right=right; - cnx=cnx} - | Conjunct (_,_) | Disjunct (_,_) -> - {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; - size=num; - left=left; - right=right; - cnx=cnx} - | Arrow (f1,f2) -> - let ncnx,nright= - try - let i = Fmap.find f1 seq.left in - (i,num,f1,f2)::cnx,right - with Not_found -> - cnx,(add_one_arrow num f1 f2 right) in - match f1 with - Conjunct (_,_) | Disjunct (_,_) -> - {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; - size=num; - left=left; - right=nright; - cnx=ncnx} - | Arrow(_,_) -> - {seq with - norev_hyps=Intmap.add num f seq.norev_hyps; - size=num; - left=left; - right=nright; - cnx=ncnx} - | _ -> - {seq with - size=num; - left=left; - right=nright; - cnx=ncnx} in - {seqwd with - dep_it=nseq; - dep_hyps=Intset.add num seqwd.dep_hyps} - -exception Here_is of (int*form) - -let choose m= - try - Intmap.iter (fun i f -> raise (Here_is (i,f))) m; - raise Not_found - with - Here_is (i,f) -> (i,f) - - -let search_or seq= - match seq.gl with - Disjunct (f1,f2) -> - [{dep_it = SI_Or_l; - dep_goal = true; - dep_hyps = Intset.empty}, - [change_goal (embed seq) f1]; - {dep_it = SI_Or_r; - dep_goal = true; - dep_hyps = Intset.empty}, - [change_goal (embed seq) f2]] - | _ -> [] - -let search_norev seq= - let goals=ref (search_or seq) in - let add_one i f= - match f with - Arrow (Arrow (f1,f2),f3) -> - let nseq = - {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in - goals:= - ({dep_it=SD_Arrow(i); - dep_goal=false; - dep_hyps=Intset.singleton i}, - [add_hyp - (add_hyp - (change_goal (embed nseq) f2) - (Arrow(f2,f3))) - f1; - add_hyp (embed nseq) f3]):: !goals - | _ -> anomaly "search_no_rev: can't happen" in - Intmap.iter add_one seq.norev_hyps; - List.rev !goals - -let search_in_rev_hyps seq= - try - let i,f=choose seq.rev_hyps in - let make_step step= - {dep_it=step; - dep_goal=false; - dep_hyps=Intset.singleton i} in - let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in - match f with - Conjunct (f1,f2) -> - [make_step (SE_And(i)), - [add_hyp (add_hyp (embed nseq) f1) f2]] - | Disjunct (f1,f2) -> - [make_step (SE_Or(i)), - [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] - | Arrow (Conjunct (f1,f2),f0) -> - [make_step (SD_And(i)), - [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] - | Arrow (Disjunct (f1,f2),f0) -> - [make_step (SD_Or(i)), - [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] - | _ -> anomaly "search_in_rev_hyps: can't happen" - with - Not_found -> search_norev seq - -let search_rev seq= - match seq.cnx with - (i,j,f1,f2)::next -> - let nseq= - match f1 with - Conjunct (_,_) | Disjunct (_,_) -> - {seq with cnx=next; - rev_hyps=Intmap.remove j seq.rev_hyps} - | Arrow (_,_) -> - {seq with cnx=next; - norev_hyps=Intmap.remove j seq.norev_hyps} - | _ -> - {seq with cnx=next} in - [{dep_it=SE_Arrow(i,j); - dep_goal=false; - dep_hyps=Intset.add i (Intset.singleton j)}, - [add_hyp (embed nseq) f2]] - | [] -> - match seq.gl with - Arrow (f1,f2) -> - [{dep_it=SI_Arrow; - dep_goal=true; - dep_hyps=Intset.empty}, - [add_hyp (change_goal (embed seq) f2) f1]] - | Conjunct (f1,f2) -> - [{dep_it=SI_And; - dep_goal=true; - dep_hyps=Intset.empty},[change_goal (embed seq) f1; - change_goal (embed seq) f2]] - | _ -> search_in_rev_hyps seq - -let search_all seq= - match seq.abs with - Some i -> - [{dep_it=SE_False (i); - dep_goal=false; - dep_hyps=Intset.singleton i},[]] - | None -> - try - let ax = Fmap.find seq.gl seq.left in - [{dep_it=SAx (ax); - dep_goal=true; - dep_hyps=Intset.singleton ax},[]] - with Not_found -> search_rev seq - -let bare_sequent = embed - {rev_hyps=Intmap.empty; - norev_hyps=Intmap.empty; - size=0; - left=Fmap.empty; - right=Fmap.empty; - cnx=[]; - abs=None; - gl=Bot} - -let init_state hyps gl= - let init = change_goal bare_sequent gl in - let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in - Incomplete (goal.dep_it,[]) - -let success= function - Complete _ -> true - | Incomplete (_,_) -> false - -let branching = function - Incomplete (seq,stack) -> - check_for_interrupt (); - let successors = search_all seq in - let _ = - match successors with - [] -> s_info.branch_failures<-s_info.branch_failures+1 - | _::next -> - s_info.nd_branching<-s_info.nd_branching+List.length next in - List.map (append stack) successors - | Complete prf -> anomaly "already succeeded" - -open Pp - -let rec pp_form = - function - Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2) - | f -> pp_or f -and pp_or = function - Disjunct(f1,f2) -> - (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2) - | f -> pp_and f -and pp_and = function - Conjunct(f1,f2) -> - (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2) - | f -> pp_atom f -and pp_atom= function - Bot -> str "#" - | Atom n -> int n - | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" - -let pr_form f = msg (pp_form f) - -let pp_intmap map = - let pp=ref (str "") in - Intmap.iter (fun i obj -> pp:= (!pp ++ - pp_form obj ++ cut ())) map; - str "{ " ++ v 0 (!pp) ++ str " }" - -let pp_list pp_obj l= -let pp=ref (str "") in - List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l; - str "[ " ++ !pp ++ str "]" - -let pp_mapint map = - let pp=ref (str "") in - Fmap.iter (fun obj l -> pp:= (!pp ++ - pp_form obj ++ str " => " ++ - pp_list (fun (i,f) -> pp_form f) l ++ - cut ()) ) map; - str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () - -let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 - -let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ - begin - match gl.abs with - None -> str "" - | Some i -> str "ABSURD" ++ cut () - end ++ - str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ - str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ - str "arrows=" ++ pp_mapint gl.right ++ cut () ++ - str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ - str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () - -let pp = - function - Incomplete(gl,ctx) -> msgnl (pp_gl gl) - | _ -> msg (str "<complete>") - -let pp_info () = - let count_info = - if !pruning then - str "Proof steps : " ++ - int s_info.created_steps ++ str " created / " ++ - int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created / " ++ - int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created / " ++ - int s_info.pruned_hyps ++ str " pruned" ++ fnl () - else - str "Pruning is off" ++ fnl () ++ - str "Proof steps : " ++ - int s_info.created_steps ++ str " created" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created" ++ fnl () in - msgnl - ( str "Proof-search statistics :" ++ fnl () ++ - count_info ++ - str "Branch ends: " ++ - int s_info.branch_successes ++ str " successes / " ++ - int s_info.branch_failures ++ str " failures" ++ fnl () ++ - str "Non-deterministic choices : " ++ - int s_info.nd_branching ++ str " branches") - - - diff --git a/contrib/rtauto/proof_search.mli b/contrib/rtauto/proof_search.mli deleted file mode 100644 index eb11aeae..00000000 --- a/contrib/rtauto/proof_search.mli +++ /dev/null @@ -1,49 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: proof_search.mli 7233 2005-07-15 12:34:56Z corbinea $ *) - -type form= - Atom of int - | Arrow of form * form - | Bot - | Conjunct of form * form - | Disjunct of form * form - -type proof = - Ax of int - | I_Arrow of proof - | E_Arrow of int*int*proof - | D_Arrow of int*proof*proof - | E_False of int - | I_And of proof*proof - | E_And of int*proof - | D_And of int*proof - | I_Or_l of proof - | I_Or_r of proof - | E_Or of int*proof*proof - | D_Or of int*proof - | Pop of int*proof - -type state - -val project: state -> proof - -val init_state : ('a * form * 'b) list -> form -> state - -val branching: state -> state list - -val success: state -> bool - -val pp: state -> unit - -val pr_form : form -> unit - -val reset_info : unit -> unit - -val pp_info : unit -> unit diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml deleted file mode 100644 index 81256f4a..00000000 --- a/contrib/rtauto/refl_tauto.ml +++ /dev/null @@ -1,337 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *) - -module Search = Explore.Make(Proof_search) - -open Util -open Term -open Termops -open Names -open Evd -open Tacmach -open Proof_search - -let force count lazc = incr count;Lazy.force lazc - -let step_count = ref 0 - -let node_count = ref 0 - -let logic_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] - -let li_False = lazy (destInd (logic_constant "False")) -let li_and = lazy (destInd (logic_constant "and")) -let li_or = lazy (destInd (logic_constant "or")) - -let data_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] - -let l_true_equals_true = - lazy (mkApp(logic_constant "refl_equal", - [|data_constant "bool";data_constant "true"|])) - -let pos_constant = - Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"] - -let l_xI = lazy (pos_constant "xI") -let l_xO = lazy (pos_constant "xO") -let l_xH = lazy (pos_constant "xH") - -let store_constant = - Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"] - -let l_empty = lazy (store_constant "empty") -let l_push = lazy (store_constant "push") - -let constant= - Coqlib.gen_constant "refl_tauto" ["rtauto";"Rtauto"] - -let l_Reflect = lazy (constant "Reflect") - -let l_Atom = lazy (constant "Atom") -let l_Arrow = lazy (constant "Arrow") -let l_Bot = lazy (constant "Bot") -let l_Conjunct = lazy (constant "Conjunct") -let l_Disjunct = lazy (constant "Disjunct") - -let l_Ax = lazy (constant "Ax") -let l_I_Arrow = lazy (constant "I_Arrow") -let l_E_Arrow = lazy (constant "E_Arrow") -let l_D_Arrow = lazy (constant "D_Arrow") -let l_E_False = lazy (constant "E_False") -let l_I_And = lazy (constant "I_And") -let l_E_And = lazy (constant "E_And") -let l_D_And = lazy (constant "D_And") -let l_I_Or_l = lazy (constant "I_Or_l") -let l_I_Or_r = lazy (constant "I_Or_r") -let l_E_Or = lazy (constant "E_Or") -let l_D_Or = lazy (constant "D_Or") - - -let special_whd gl= - let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) - -let special_nf gl= - let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) - -type atom_env= - {mutable next:int; - mutable env:(constr*int) list} - -let make_atom atom_env term= - try - let (_,i)= - List.find (fun (t,_)-> eq_constr term t) atom_env.env - in Atom i - with Not_found -> - let i=atom_env.next in - atom_env.env <- (term,i)::atom_env.env; - atom_env.next<- i + 1; - Atom i - -let rec make_form atom_env gls term = - let normalize=special_nf gls in - let cciterm=special_whd gls term in - match kind_of_term cciterm with - Prod(_,a,b) -> - if not (dependent (mkRel 1) b) && - Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) a = InProp - then - let fa=make_form atom_env gls a in - let fb=make_form atom_env gls b in - Arrow (fa,fb) - else - make_atom atom_env (normalize term) - | Cast(a,_,_) -> - make_form atom_env gls a - | Ind ind -> - if ind = Lazy.force li_False then - Bot - else - make_atom atom_env (normalize term) - | App(hd,argv) when Array.length argv = 2 -> - begin - try - let ind = destInd hd in - if ind = Lazy.force li_and then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Conjunct (fa,fb) - else if ind = Lazy.force li_or then - let fa=make_form atom_env gls argv.(0) in - let fb=make_form atom_env gls argv.(1) in - Disjunct (fa,fb) - else make_atom atom_env (normalize term) - with Invalid_argument _ -> make_atom atom_env (normalize term) - end - | _ -> make_atom atom_env (normalize term) - -let rec make_hyps atom_env gls lenv = function - [] -> [] - | (_,Some body,typ)::rest -> - make_hyps atom_env gls (typ::body::lenv) rest - | (id,None,typ)::rest -> - let hrec= - make_hyps atom_env gls (typ::lenv) rest in - if List.exists (dependent (mkVar id)) lenv || - (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ <> InProp) - then - hrec - else - (id,make_form atom_env gls typ)::hrec - -let rec build_pos n = - if n<=1 then force node_count l_xH - else if n land 1 = 0 then - mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) - else - mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) - -let rec build_form = function - Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) - | Arrow (f1,f2) -> - mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) - | Bot -> force node_count l_Bot - | Conjunct (f1,f2) -> - mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) - | Disjunct (f1,f2) -> - mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) - -let rec decal k = function - [] -> k - | (start,delta)::rest -> - if k>start then - k - delta - else - decal k rest - -let add_pop size d pops= - match pops with - [] -> [size+d,d] - | (_,sum)::_ -> (size+sum,sum+d)::pops - -let rec build_proof pops size = - function - Ax i -> - mkApp (force step_count l_Ax, - [|build_pos (decal i pops)|]) - | I_Arrow p -> - mkApp (force step_count l_I_Arrow, - [|build_proof pops (size + 1) p|]) - | E_Arrow(i,j,p) -> - mkApp (force step_count l_E_Arrow, - [|build_pos (decal i pops); - build_pos (decal j pops); - build_proof pops (size + 1) p|]) - | D_Arrow(i,p1,p2) -> - mkApp (force step_count l_D_Arrow, - [|build_pos (decal i pops); - build_proof pops (size + 2) p1; - build_proof pops (size + 1) p2|]) - | E_False i -> - mkApp (force step_count l_E_False, - [|build_pos (decal i pops)|]) - | I_And(p1,p2) -> - mkApp (force step_count l_I_And, - [|build_proof pops size p1; - build_proof pops size p2|]) - | E_And(i,p) -> - mkApp (force step_count l_E_And, - [|build_pos (decal i pops); - build_proof pops (size + 2) p|]) - | D_And(i,p) -> - mkApp (force step_count l_D_And, - [|build_pos (decal i pops); - build_proof pops (size + 1) p|]) - | I_Or_l(p) -> - mkApp (force step_count l_I_Or_l, - [|build_proof pops size p|]) - | I_Or_r(p) -> - mkApp (force step_count l_I_Or_r, - [|build_proof pops size p|]) - | E_Or(i,p1,p2) -> - mkApp (force step_count l_E_Or, - [|build_pos (decal i pops); - build_proof pops (size + 1) p1; - build_proof pops (size + 1) p2|]) - | D_Or(i,p) -> - mkApp (force step_count l_D_Or, - [|build_pos (decal i pops); - build_proof pops (size + 2) p|]) - | Pop(d,p) -> - build_proof (add_pop size d pops) size p - -let build_env gamma= - List.fold_right (fun (p,_) e -> - mkApp(force node_count l_push,[|mkProp;p;e|])) - gamma.env (mkApp (force node_count l_empty,[|mkProp|])) - -open Goptions - -let verbose = ref false - -let opt_verbose= - {optsync=true; - optname="Rtauto Verbose"; - optkey=SecondaryTable("Rtauto","Verbose"); - optread=(fun () -> !verbose); - optwrite=(fun b -> verbose:=b)} - -let _ = declare_bool_option opt_verbose - -let check = ref false - -let opt_check= - {optsync=true; - optname="Rtauto Check"; - optkey=SecondaryTable("Rtauto","Check"); - optread=(fun () -> !check); - optwrite=(fun b -> check:=b)} - -let _ = declare_bool_option opt_check - -open Pp - -let rtauto_tac gls= - Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; - let gamma={next=1;env=[]} in - let gl=gls.it.evar_concl in - let _= - if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl <> InProp - then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in - let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] - (Environ.named_context_of_val gls.it.evar_hyps) in - let formula= - List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in - let search_fun = - if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then - Search.debug_depth_first - else - Search.depth_first in - let _ = - begin - reset_info (); - if !verbose then - msgnl (str "Starting proof-search ..."); - end in - let search_start_time = System.get_time () in - let prf = - try project (search_fun (init_state [] formula)) - with Not_found -> - errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in - let search_end_time = System.get_time () in - let _ = if !verbose then - begin - msgnl (str "Proof tree found in " ++ - System.fmt_time_difference search_start_time search_end_time); - pp_info (); - msgnl (str "Building proof term ... ") - end in - let build_start_time=System.get_time () in - let _ = step_count := 0; node_count := 0 in - let main = mkApp (force node_count l_Reflect, - [|build_env gamma; - build_form formula; - build_proof [] 0 prf|]) in - let term= - Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in - let build_end_time=System.get_time () in - let _ = if !verbose then - begin - msgnl (str "Proof term built in " ++ - System.fmt_time_difference build_start_time build_end_time ++ - fnl () ++ - str "Proof size : " ++ int !step_count ++ - str " steps" ++ fnl () ++ - str "Proof term size : " ++ int (!step_count+ !node_count) ++ - str " nodes (constants)" ++ fnl () ++ - str "Giving proof term to Coq ... ") - end in - let tac_start_time = System.get_time () in - let result= - if !check then - Tactics.exact_check term gls - else - Tactics.exact_no_check term gls in - let tac_end_time = System.get_time () in - let _ = - if !check then msgnl (str "Proof term type-checking is on"); - if !verbose then - msgnl (str "Internal tactic executed in " ++ - System.fmt_time_difference tac_start_time tac_end_time) in - result - diff --git a/contrib/rtauto/refl_tauto.mli b/contrib/rtauto/refl_tauto.mli deleted file mode 100644 index 480dbb30..00000000 --- a/contrib/rtauto/refl_tauto.mli +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* $Id: refl_tauto.mli 7233 2005-07-15 12:34:56Z corbinea $ *) - -(* raises Not_found if no proof is found *) - -type atom_env= - {mutable next:int; - mutable env:(Term.constr*int) list} - -val make_form : atom_env -> - Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form - -val make_hyps : - atom_env -> - Proof_type.goal Tacmach.sigma -> - Term.types list -> - (Names.identifier * Term.types option * Term.types) list -> - (Names.identifier * Proof_search.form) list - -val rtauto_tac : Proof_type.tactic diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v deleted file mode 100644 index 601cabe0..00000000 --- a/contrib/setoid_ring/ArithRing.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Mult. -Require Import BinNat. -Require Import Nnat. -Require Export Ring. -Set Implicit Arguments. - -Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). - Proof. - constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. - exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. - Qed. - -Lemma nat_morph_N : - semi_morph 0 1 plus mult (eq (A:=nat)) - 0%N 1%N Nplus Nmult Neq_bool nat_of_N. -Proof. - constructor;trivial. - exact nat_of_Nplus. - exact nat_of_Nmult. - intros x y H;rewrite (Neq_bool_ok _ _ H);trivial. -Qed. - -Ltac natcst t := - match isnatcst t with - true => constr:(N_of_nat t) - | _ => constr:InitialRing.NotConstant - end. - -Ltac Ss_to_add f acc := - match f with - | S ?f1 => Ss_to_add f1 (S acc) - | _ => constr:(acc + f)%nat - end. - -Ltac natprering := - match goal with - |- context C [S ?p] => - match p with - O => fail 1 (* avoid replacing 1 with 1+0 ! *) - | p => match isnatcst p with - | true => fail 1 - | false => let v := Ss_to_add p (S 0) in - fold v; natprering - end - end - | _ => idtac - end. - -Add Ring natr : natSRth - (morphism nat_morph_N, constants [natcst], preprocess [natprering]). - diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v deleted file mode 100644 index 50902004..00000000 --- a/contrib/setoid_ring/BinList.v +++ /dev/null @@ -1,93 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Set Implicit Arguments. -Require Import BinPos. -Require Export List. -Require Export ListTactics. -Open Local Scope positive_scope. - -Section MakeBinList. - Variable A : Type. - Variable default : A. - - Fixpoint jump (p:positive) (l:list A) {struct p} : list A := - match p with - | xH => tail l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tail l)) - end. - - Fixpoint nth (p:positive) (l:list A) {struct p} : A:= - match p with - | xH => hd default l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - - Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. - induction j;simpl;intros. - repeat rewrite IHj;trivial. - repeat rewrite IHj;trivial. - trivial. - Qed. - - Lemma jump_Psucc : forall j l, - (jump (Psucc j) l) = (jump 1 (jump j l)). - Proof. - induction j;simpl;intros. - repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial. - repeat rewrite jump_tl;trivial. - trivial. - Qed. - - Lemma jump_Pplus : forall i j l, - (jump (i + j) l) = (jump i (jump j l)). - Proof. - induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;trivial. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. - Qed. - - Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). - Proof. - induction i;intros;simpl. - repeat rewrite jump_tl;trivial. - rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial. - trivial. - Qed. - - - Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). - Proof. - induction p;simpl;intros. - rewrite <-jump_tl;rewrite IHp;trivial. - rewrite <-jump_tl;rewrite IHp;trivial. - trivial. - Qed. - - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). - Proof. - induction p;simpl;intros. - repeat rewrite jump_tl;trivial. - rewrite jump_Pdouble_minus_one. - repeat rewrite <- jump_tl;rewrite IHp;trivial. - trivial. - Qed. - -End MakeBinList. - - diff --git a/contrib/setoid_ring/Field.v b/contrib/setoid_ring/Field.v deleted file mode 100644 index a944ba5f..00000000 --- a/contrib/setoid_ring/Field.v +++ /dev/null @@ -1,10 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Export Field_theory. -Require Export Field_tac. diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v deleted file mode 100644 index cccee604..00000000 --- a/contrib/setoid_ring/Field_tac.v +++ /dev/null @@ -1,406 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Ring_tac BinList Ring_polynom InitialRing. -Require Export Field_theory. - - (* syntaxification *) - Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := - let rec mkP t := - match Cst t with - | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEadd e1 e2) - | (rmul ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEmul e1 e2) - | (rsub ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEsub e1 e2) - | (ropp ?t1) => - let e1 := mkP t1 in constr:(FEopp e1) - | (rdiv ?t1 ?t2) => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(FEdiv e1 e2) - | (rinv ?t1) => - let e1 := mkP t1 in constr:(FEinv e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - let p := Find_at t fv in constr:(@FEX C p) - | ?c => let e1 := mkP t1 in constr:(FEpow e1 c) - end - - | _ => - let p := Find_at t fv in constr:(@FEX C p) - end - | ?c => constr:(FEc c) - end - in mkP t. - -Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := - let rec TFV t fv := - match Cst t with - | InitialRing.NotConstant => - match t with - | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => TFV t1 fv - | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (inv ?t1) => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => AddFvTail t fv - | _ => TFV t1 fv - end - | _ => AddFvTail t fv - end - | _ => fv - end - in TFV t fv. - -Ltac ParseFieldComponents lemma req := - match type of lemma with - | context [ - (* PCond _ _ _ _ _ _ _ _ _ _ _ -> *) - req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv - ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => - (fun f => f radd rmul rsub ropp rdiv rinv rpow C) - | _ => fail 1 "field anomaly: bad correctness lemma (parse)" - end. - -(* simplifying the non-zero condition... *) - -Ltac fold_field_cond req := - let rec fold_concl t := - match t with - ?x /\ ?y => - let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) - | req ?x ?y -> False => constr:(~ req x y) - | _ => t - end in - match goal with - |- ?t => let ft := fold_concl t in change ft - end. - -Ltac simpl_PCond req := - protect_fv "field_cond"; - (try exact I); - fold_field_cond req. - -Ltac simpl_PCond_BEURK req := - protect_fv "field_cond"; - fold_field_cond req. - -(* Rewriting (field_simplify) *) -Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let fv := FV_hypo_tac mkFV req lH in - let simpl_field H := (protect_fv "field" in H;f H) in - let lemma_tac fv RW_tac := - let rr_lemma := fresh "f_rw_lemma" in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in - let vlpe := fresh "list_hyp" in - let vlmp := fresh "list_hyp_norm" in - let vlmp_eq := fresh "list_hyp_norm_eq" in - let prh := proofHyp_tac lH in - pose (vlpe := lpe); - match type of lemma with - | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] => - compute_assertion vlmp_eq vlmp - (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); - (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq) - || fail 1 "type error when build the rewriting lemma"); - RW_tac rr_lemma; - try clear rr_lemma vlmp_eq vlmp vlpe - | _ => fail 1 "field_simplify anomaly: bad correctness lemma" - end in - ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl; - try (apply Cond_lemma; simpl_PCond req) in - ParseFieldComponents lemma req Main. - -Ltac Field_simplify_gen f := - fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl => - pre(); - Field_norm_gen f cst_tac pow_tac field_simplify_ok cond_ok req - ring_subst_niter lH rl; - post(). - -Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "field_simplify" constr_list(rl) := - let G := Get_goal in - field_lookup Field_simplify [] rl G. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - field_lookup Field_simplify [lH] rl G. - -Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H;clear H; - field_lookup Field_simplify [] rl t; - intro H; - unfold g;clear g. - -Tactic Notation "field_simplify" - "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H;clear H; - field_lookup Field_simplify [lH] rl t; - intro H; - unfold g;clear g. - -(* -Ltac Field_simplify_in hyp:= - Field_simplify_gen ltac:(fun H => rewrite H in hyp). - -Tactic Notation (at level 0) - "field_simplify" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [] rl t. - -Tactic Notation (at level 0) - "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := - let t := type of h in - field_lookup (Field_simplify_in h) [lH] rl t. -*) - -(** Generic tactic for solving equations *) - -Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let rec ParseExpr ilemma := - match type of ilemma with - forall nfe, ?fe = nfe -> _ => - (fun t => - let x := fresh "fld_expr" in - let H := fresh "norm_fld_expr" in - compute_assertion H x fe; - ParseExpr (ilemma x H) t; - try clear x H) - | _ => (fun t => t ilemma) - end in - let Main_eq t1 t2 := - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in - let prh := proofHyp_tac lH in - let vlpe := fresh "list_hyp" in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - pose (vlpe := lpe); - let nlemma := fresh "field_lemma" in - (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) - || fail "field anomaly:failed to build lemma"); - ParseExpr nlemma - ltac:(fun ilemma => - apply ilemma - || fail "field anomaly: failed in applying lemma"; - [ Simpl_tac | apply Cond_lemma; simpl_PCond req]); - clear vlpe nlemma in - OnEquation req Main_eq in - ParseFieldComponents lemma req Main. - -(* solve completely a field equation, leaving non-zero conditions to be - proved (field) *) - -Ltac FIELD := - let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in - fun req cst_tac pow_tac field_ok _ _ _ cond_ok pre post lH rl => - pre(); - Field_Scheme Simpl cst_tac pow_tac field_ok cond_ok req - Ring_tac.ring_subst_niter lH; - try exact I; - post(). - -Tactic Notation (at level 0) "field" := - let G := Get_goal in - field_lookup FIELD [] G. - -Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup FIELD [lH] G. - -(* transforms a field equation to an equivalent (simplified) ring equation, - and leaves non-zero conditions to be proved (field_simplify_eq) *) -Ltac FIELD_SIMPL := - let Simpl := (protect_fv "field") in - fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl => - pre(); - Field_Scheme Simpl cst_tac pow_tac field_simplify_eq_ok cond_ok - req Ring_tac.ring_subst_niter lH; - post(). - -Tactic Notation (at level 0) "field_simplify_eq" := - let G := Get_goal in - field_lookup FIELD_SIMPL [] G. - -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := - let G := Get_goal in - field_lookup FIELD_SIMPL [lH] G. - -(* Same as FIELD_SIMPL but in hypothesis *) - -Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH := - let Main radd rmul rsub ropp rdiv rinv rpow C := - let hyp := fresh "hyp" in - intro hyp; - match type of hyp with - | req ?t1 ?t2 => - let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in - let mkFFV := FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let mkFE := - mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow in - let rec ParseExpr ilemma := - match type of ilemma with - | forall nfe, ?fe = nfe -> _ => - (fun t => - let x := fresh "fld_expr" in - let H := fresh "norm_fld_expr" in - compute_assertion H x fe; - ParseExpr (ilemma x H) t; - try clear H x) - | _ => (fun t => t ilemma) - end in - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFFV t1 fv in - let fv := mkFFV t2 fv in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in - let prh := proofHyp_tac lH in - let fe1 := mkFE t1 fv in - let fe2 := mkFE t2 fv in - let vlpe := fresh "vlpe" in - ParseExpr (lemma n fv lpe fe1 fe2 prh) - ltac:(fun ilemma => - match type of ilemma with - | req _ _ -> _ -> ?EQ => - let tmp := fresh "tmp" in - assert (tmp : EQ); - [ apply ilemma; - [ exact hyp | apply Cond_lemma; simpl_PCond_BEURK req] - | protect_fv "field" in tmp; - generalize tmp;clear tmp ]; - clear hyp - end) - end in - ParseFieldComponents lemma req Main. - -Ltac FIELD_SIMPL_EQ := - fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl => - pre(); - Field_simplify_eq cst_tac pow_tac lemma cond_ok req - Ring_tac.ring_subst_niter lH; - post(). - -Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup FIELD_SIMPL_EQ [] t; - [ try exact I - | clear H;intro H]. - - -Tactic Notation (at level 0) - "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := - let t := type of H in - generalize H; - field_lookup FIELD_SIMPL_EQ [lH] t; - [ try exact I - |clear H;intro H]. - -(* Adding a new field *) - -Ltac ring_of_field f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) - end. - -Ltac coerce_to_almost_field set ext f := - match type of f with - | almost_field_theory _ _ _ _ _ _ _ _ _ => f - | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) - | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) - end. - -Ltac field_elements set ext fspec pspec sspec dspec rk := - let afth := coerce_to_almost_field set ext fspec in - let rspec := ring_of_field fspec in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec). - -Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := - let get_lemma := - match pspec with None => fun x y => x | _ => fun x y => y end in - let simpl_eq_lemma := get_lemma - Field_simplify_eq_correct Field_simplify_eq_pow_correct in - let simpl_eq_in_lemma := get_lemma - Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in - let rw_lemma := get_lemma - Field_rw_correct Field_rw_pow_correct in - field_elements set ext fspec pspec sspec dspec rk - ltac:(fun afth ext_r morph p_spec s_spec d_spec => - match morph with - | _ => - let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in - match p_spec with - | mkhypo ?pp_spec => - let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in - match s_spec with - | mkhypo ?ss_spec => - let field_ok3 := constr:(field_ok2 _ ss_spec) in - match d_spec with - | mkhypo ?dd_spec => - let field_ok := constr:(field_ok3 _ dd_spec) in - let mk_lemma lemma := - constr:(lemma _ _ _ _ _ _ _ _ _ _ - set ext_r inv_m afth - _ _ _ _ _ _ _ _ _ morph - _ _ _ pp_spec _ ss_spec _ dd_spec) in - let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in - let field_simpl_ok := mk_lemma rw_lemma in - let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in - let cond1_ok := - constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in - let cond2_ok := - constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in - (fun f => - f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in - cond1_ok cond2_ok) - | _ => fail 4 "field: bad coefficiant division specification" - end - | _ => fail 3 "field: bad sign specification" - end - | _ => fail 2 "field: bad power specification" - end - | _ => fail 1 "field internal error : field_lemmas, please report" - end). diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v deleted file mode 100644 index b2e5cc4b..00000000 --- a/contrib/setoid_ring/Field_theory.v +++ /dev/null @@ -1,1944 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Ring. -Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List. -Require Import ZArith_base. -(*Require Import Omega.*) -Set Implicit Arguments. - -Section MakeFieldPol. - -(* Field elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable (rdiv : R -> R -> R) (rinv : R -> R). - Variable req : R -> R -> Prop. - - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y). - Notation "- x" := (ropp x). Notation "/ x" := (rinv x). - Notation "x == y" := (req x y) (at level 70, no associativity). - - (* Equality properties *) - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable SRinv_ext : forall p q, p == q -> / p == / q. - - (* Field properties *) - Record almost_field_theory : Prop := mk_afield { - AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; - AF_1_neq_0 : ~ 1 == 0; - AFdiv_def : forall p q, p / q == p * / q; - AFinv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - -Section AlmostField. - - Variable AFth : almost_field_theory. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - -Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type), - (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y). -Proof. -intros. -generalize (fun h => X (morph_eq CRmorph c1 c2 h)). -case (ceqb c1 c2); auto. -Qed. - - - (* C notations *) - Notation "x +! y" := (cadd x y) (at level 50). - Notation "x *! y " := (cmul x y) (at level 40). - Notation "x -! y " := (csub x y) (at level 50). - Notation "-! x" := (copp x) (at level 35). - Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity). - Notation "[ x ]" := (phi x) (at level 0). - - - (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. - -Let eq_trans := Setoid.Seq_trans _ _ Rsth. -Let eq_sym := Setoid.Seq_sym _ _ Rsth. -Let eq_refl := Setoid.Seq_refl _ _ Rsth. - -Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . -Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) - (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. -Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) - (ARmul_1_l ARth) (ARmul_0_l ARth) - (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) - (ARopp_mul_l ARth) (ARopp_add ARth) - (ARsub_def ARth) . - - (* Power coefficients *) - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - (* sign function *) - Variable get_sign : C -> option C. - Variable get_sign_spec : sign_theory copp ceqb get_sign. - - Variable cdiv:C -> C -> C*C. - Variable cdiv_th : div_theory req cadd cmul phi cdiv. - -Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). -Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv). - -Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign). -Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign). - -(* add abstract semi-ring to help with some proofs *) -Add Ring Rring : (ARth_SRth ARth). - - -(* additional ring properties *) - -Lemma rsub_0_l : forall r, 0 - r == - r. -intros; rewrite (ARsub_def ARth) in |- *;ring. -Qed. - -Lemma rsub_0_r : forall r, r - 0 == r. -intros; rewrite (ARsub_def ARth) in |- *. -rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. -Qed. - -(*************************************************************************** - - Properties of division - - ***************************************************************************) - -Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. -intros p q H. -rewrite rdiv_def in |- *. -transitivity (/ q * q * p); [ ring | idtac ]. -rewrite rinv_l in |- *; auto. -Qed. -Hint Resolve rdiv_simpl . - -Theorem SRdiv_ext: - forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. -intros p1 p2 H q1 q2 H0. -transitivity (p1 * / q1); auto. -transitivity (p2 * / q2); auto. -Qed. -Hint Resolve SRdiv_ext . - - Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed. - -Lemma rmul_reg_l : forall p q1 q2, - ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. -intros. -rewrite <- (@rdiv_simpl q1 p) in |- *; trivial. -rewrite <- (@rdiv_simpl q2 p) in |- *; trivial. -repeat rewrite rdiv_def in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -auto. -Qed. - -Theorem field_is_integral_domain : forall r1 r2, - ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. -Proof. -red in |- *; intros. -apply H0. -transitivity (1 * r2); auto. -transitivity (/ r1 * r1 * r2); auto. -rewrite <- (ARmul_assoc ARth) in |- *. -rewrite H1 in |- *. -apply ARmul_0_r with (1 := Rsth) (2 := ARth). -Qed. - -Theorem ropp_neq_0 : forall r, - ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. -intros. -setoid_replace (- r) with (- (1) * r). - apply field_is_integral_domain; trivial. - rewrite <- (ARopp_mul_l ARth) in |- *. - rewrite (ARmul_1_l ARth) in |- *. - reflexivity. -Qed. - -Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. -intros. -rewrite (AFdiv_def AFth) in |- *. -rewrite (ARmul_comm ARth) in |- *. -apply (AFinv_l AFth). -trivial. -Qed. - -Theorem rdiv1: forall r, r == r / 1. -intros r; transitivity (1 * (r / 1)); auto. -Qed. - -Theorem rdiv2: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl in |- *; trivial. -rewrite (ARdistr_r Rsth Reqe ARth) in |- *. -apply (Radd_ext Reqe). - transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. - transitivity (r2 * (r4 * (r3 / r4))); auto. - transitivity (r2 * r3); auto. -Qed. - - -Theorem rdiv2b: - forall r1 r2 r3 r4 r5, - ~ (r2*r5) == 0 -> - ~ (r4*r5) == 0 -> - r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)). -Proof. -intros r1 r2 r3 r4 r5 H H0. -assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). -assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). -assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). -assert (HH4: ~ r2 * (r4 * r5) == 0) - by complete (repeat apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * (r4 * r5)); trivial. -rewrite rdiv_simpl in |- *; trivial. -rewrite (ARdistr_r Rsth Reqe ARth) in |- *. -apply (Radd_ext Reqe). - transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ]. - transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ]. -Qed. - -Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2. -intros r1 r2. -transitivity (- (r1 * / r2)); auto. -transitivity (- r1 * / r2); auto. -Qed. -Hint Resolve rdiv5 . - -Theorem rdiv3: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). -transitivity (r1 / r2 + - (r3 / r4)); auto. -transitivity (r1 / r2 + - r3 / r4); auto. -transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto. -apply rdiv2; auto. -apply SRdiv_ext; auto. -transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. -Qed. - - -Theorem rdiv3b: - forall r1 r2 r3 r4 r5, - ~ (r2 * r5) == 0 -> - ~ (r4 * r5) == 0 -> - r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)). -Proof. -intros r1 r2 r3 r4 r5 H H0. -transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto. -transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto. -transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))). -apply rdiv2b; auto; try ring. -apply (SRdiv_ext); auto. -transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. -Qed. - -Theorem rdiv6: - forall r1 r2, - ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1. -intros r1 r2 H H0. -assert (~ r1 / r2 == 0) as Hk. - intros H1; case H. - transitivity (r2 * (r1 / r2)); auto. - rewrite H1 in |- *; ring. - apply rmul_reg_l with (r1 / r2); auto. - transitivity (/ (r1 / r2) * (r1 / r2)); auto. - transitivity 1; auto. - repeat rewrite rdiv_def in |- *. - transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. - repeat rewrite rinv_l in |- *; auto. -Qed. -Hint Resolve rdiv6 . - - Theorem rdiv4: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r4 == 0 -> - (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 H H0. -assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). -apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl in |- *; trivial. -transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. -repeat rewrite rdiv_simpl in |- *; trivial. -Qed. - - Theorem rdiv4b: - forall r1 r2 r3 r4 r5 r6, - ~ r2 * r5 == 0 -> - ~ r4 * r6 == 0 -> - ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4). -Proof. -intros r1 r2 r3 r4 r5 r6 H H0. -rewrite rdiv4; auto. -transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))). -apply SRdiv_ext; ring. -assert (HH: ~ r5*r6 == 0). - apply field_is_integral_domain. - intros H1; case H; rewrite H1; ring. - intros H1; case H0; rewrite H1; ring. -rewrite <- rdiv4 ; auto. - rewrite rdiv_r_r; auto. - - apply field_is_integral_domain. - intros H1; case H; rewrite H1; ring. - intros H1; case H0; rewrite H1; ring. -Qed. - - -Theorem rdiv7: - forall r1 r2 r3 r4, - ~ r2 == 0 -> - ~ r3 == 0 -> - ~ r4 == 0 -> - (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). -Proof. -intros. -rewrite (rdiv_def (r1 / r2)) in |- *. -rewrite rdiv6 in |- *; trivial. -apply rdiv4; trivial. -Qed. - -Theorem rdiv7b: - forall r1 r2 r3 r4 r5 r6, - ~ r2 * r6 == 0 -> - ~ r3 * r5 == 0 -> - ~ r4 * r6 == 0 -> - ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3). -Proof. -intros. -rewrite rdiv7; auto. -transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))). -apply SRdiv_ext; ring. -assert (HH: ~ r5*r6 == 0). - apply field_is_integral_domain. - intros H2; case H0; rewrite H2; ring. - intros H2; case H1; rewrite H2; ring. -rewrite <- rdiv4 ; auto. -rewrite rdiv_r_r; auto. - apply field_is_integral_domain. - intros H2; case H; rewrite H2; ring. - intros H2; case H0; rewrite H2; ring. -Qed. - - -Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. -intros r1 r2 H H0. -transitivity (r1 * / r2); auto. -transitivity (0 * / r2); auto. -Qed. - - -Theorem cross_product_eq : forall r1 r2 r3 r4, - ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4. -intros. -transitivity (r1 / r2 * (r4 / r4)). - rewrite rdiv_r_r in |- *; trivial. - symmetry in |- *. - apply (ARmul_1_r Rsth ARth). - rewrite rdiv4 in |- *; trivial. - rewrite H1 in |- *. - rewrite (ARmul_comm ARth r2 r4) in |- *. - rewrite <- rdiv4 in |- *; trivial. - rewrite rdiv_r_r in |- * by trivial. - apply (ARmul_1_r Rsth ARth). -Qed. - -(*************************************************************************** - - Some equality test - - ***************************************************************************) - -Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := - match p1, p2 with - xH, xH => true - | xO p3, xO p4 => positive_eq p3 p4 - | xI p3, xI p4 => positive_eq p3 p4 - | _, _ => false - end. - -Theorem positive_eq_correct: - forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. -intros p1; elim p1; - (try (intros p2; case p2; simpl; auto; intros; discriminate)). -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xI ); auto. -intros H1 H2; case H1; injection H2; auto. -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xO ); auto. -intros H1 H2; case H1; injection H2; auto. -Qed. - -Definition N_eq n1 n2 := - match n1, n2 with - | N0, N0 => true - | Npos p1, Npos p2 => positive_eq p1 p2 - | _, _ => false - end. - -Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2. -Proof. - intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail). - assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2); - [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial]. -Qed. - -(* equality test *) -Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := - match e1, e2 with - PEc c1, PEc c2 => ceqb c1 c2 - | PEX p1, PEX p2 => positive_eq p1 p2 - | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false - | PEopp e3, PEopp e4 => PExpr_eq e3 e4 - | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false - | _, _ => false - end. - -Add Morphism (pow_pos rmul) : pow_morph. -intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. -Qed. - -Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph. -intros x y H [|p];simpl;auto. apply pow_morph;trivial. -Qed. -(* -Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n). -Proof. - intros; repeat rewrite pow_th.(rpow_pow_N). - destruct n;simpl. apply eq_refl. - induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl. -Qed. -*) -Theorem PExpr_eq_semi_correct: - forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. -intros l e1; elim e1. -intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). -intros c2; apply (morph_eq CRmorph). -intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). -intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2); - (try (intros; discriminate)); intros H; rewrite H; auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). -intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); - (try (intros; discriminate)); auto. -intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). -intros e4; generalize (rec e4); case (PExpr_eq e3 e4); - (try (intros; discriminate)); auto. -intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). -intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4); -intros;try discriminate. -repeat rewrite pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto. -Qed. - -(* add *) -Definition NPEadd e1 e2 := - match e1, e2 with - PEc c1, PEc c2 => PEc (cadd c1 c2) - | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 - | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 - (* Peut t'on factoriser ici ??? *) - | _, _ => PEadd e1 e2 - end. - -Theorem NPEadd_correct: - forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). -Proof. -intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl; - try (ring [(morph0 CRmorph)]). - apply (morph_add CRmorph). -Qed. - -Definition NPEpow x n := - match n with - | N0 => PEc cI - | Npos p => - if positive_eq p xH then x else - match x with - | PEc c => - if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) - | _ => PEpow x n - end - end. - -Theorem NPEpow_correct : forall l e n, - NPEeval l (NPEpow e n) == NPEeval l (PEpow e n). -Proof. - destruct n;simpl. - rewrite pow_th.(rpow_pow_N);simpl;auto. - generalize (positive_eq_correct p xH). - destruct (positive_eq p 1);intros. - rewrite H;rewrite pow_th.(rpow_pow_N). trivial. - clear H;destruct e;simpl;auto. - repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. - symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. - symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. - induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. -Qed. - -(* mul *) -Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := - match x, y with - PEc c1, PEc c2 => PEc (cmul c1 c2) - | PEc c, _ => - if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y - | _, PEc c => - if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y - | PEpow e1 n1, PEpow e2 n2 => - if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y - | _, _ => PEmul x y - end. - -Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. -induction p;simpl;auto;try ring [IHp]. -Qed. - -Theorem NPEmul_correct : forall l e1 e2, - NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). -induction e1;destruct e2; simpl in |- *;try reflexivity; - repeat apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; - try ring [(morph0 CRmorph) (morph1 CRmorph)]. - apply (morph_mul CRmorph). -assert (H:=N_eq_correct n n0);destruct (N_eq n n0). -rewrite NPEpow_correct. simpl. -repeat rewrite pow_th.(rpow_pow_N). -rewrite IHe1;rewrite <- H;destruct n;simpl;try ring. -apply pow_pos_mul. -simpl;auto. -Qed. - -(* sub *) -Definition NPEsub e1 e2 := - match e1, e2 with - PEc c1, PEc c2 => PEc (csub c1 c2) - | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 - | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 - (* Peut-on factoriser ici *) - | _, _ => PEsub e1 e2 - end. - -Theorem NPEsub_correct: - forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2). -intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; - try rewrite (morph0 CRmorph) in |- *; try reflexivity; - try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). -apply (morph_sub CRmorph). -Qed. - -(* opp *) -Definition NPEopp e1 := - match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. - -Theorem NPEopp_correct: - forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). -intros l e1; case e1; simpl; auto. -intros; apply (morph_opp CRmorph). -Qed. - -(* simplification *) -Fixpoint PExpr_simp (e : PExpr C) : PExpr C := - match e with - PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2) - | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) - | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) - | PEopp e1 => NPEopp (PExpr_simp e1) - | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 - | _ => e - end. - -Theorem PExpr_simp_correct: - forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. -intros l e; elim e; simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEadd_correct. -simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEsub_correct. -simpl; auto. -intros e1 He1 e2 He2. -transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. -apply NPEmul_correct. -simpl; auto. -intros e1 He1. -transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. -apply NPEopp_correct. -simpl; auto. -intros e1 He1 n;simpl. -rewrite NPEpow_correct;simpl. -repeat rewrite pow_th.(rpow_pow_N). -rewrite He1;auto. -Qed. - - -(**************************************************************************** - - Datastructure - - ***************************************************************************) - -(* The input: syntax of a field expression *) - -Inductive FExpr : Type := - FEc: C -> FExpr - | FEX: positive -> FExpr - | FEadd: FExpr -> FExpr -> FExpr - | FEsub: FExpr -> FExpr -> FExpr - | FEmul: FExpr -> FExpr -> FExpr - | FEopp: FExpr -> FExpr - | FEinv: FExpr -> FExpr - | FEdiv: FExpr -> FExpr -> FExpr - | FEpow: FExpr -> N -> FExpr . - -Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := - match pe with - | FEc c => phi c - | FEX x => BinList.nth 0 x l - | FEadd x y => FEeval l x + FEeval l y - | FEsub x y => FEeval l x - FEeval l y - | FEmul x y => FEeval l x * FEeval l y - | FEopp x => - FEeval l x - | FEinv x => / FEeval l x - | FEdiv x y => FEeval l x / FEeval l y - | FEpow x n => rpow (FEeval l x) (Cp_phi n) - end. - -Strategy expand [FEeval]. - -(* The result of the normalisation *) - -Record linear : Type := mk_linear { - num : PExpr C; - denum : PExpr C; - condition : list (PExpr C) }. - -(*************************************************************************** - - Semantics and properties of side condition - - ***************************************************************************) - -Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := - match le with - | nil => True - | e1 :: nil => ~ req (NPEeval l e1) rO - | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1 - end. - -Theorem PCond_cons_inv_l : - forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0. -intros l a l1 H. -destruct l1; simpl in H |- *; trivial. -destruct H; trivial. -Qed. - -Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. -intros l a l1 H. -destruct l1; simpl in H |- *; trivial. -destruct H; trivial. -Qed. - -Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1. -intros l l1 l2; elim l1; simpl app in |- *. - simpl in |- *; auto. - destruct l0; simpl in *. - destruct l2; firstorder. - firstorder. -Qed. - -Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. -intros l l1 l2; elim l1; simpl app; auto. -intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). -Qed. - -(* An unsatisfiable condition: issued when a division by zero is detected *) -Definition absurd_PCond := cons (PEc cO) nil. - -Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. -unfold absurd_PCond in |- *; simpl in |- *. -red in |- *; intros. -apply H. -apply (morph0 CRmorph). -Qed. - -(*************************************************************************** - - Normalisation - - ***************************************************************************) - -Fixpoint isIn (e1:PExpr C) (p1:positive) - (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) := - match e2 with - | PEmul e3 e4 => - match isIn e1 p1 e3 p2 with - | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) - | Some (Npos p, e5) => - match isIn e1 p e4 p2 with - | Some (n, e6) => Some (n, NPEmul e5 e6) - | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) - end - | None => - match isIn e1 p1 e4 p2 with - | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) - | None => None - end - end - | PEpow e3 N0 => None - | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) - | _ => - if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with - | Zpos p => Some (Npos p, PEc cI) - | Z0 => Some (N0, PEc cI) - | Zneg p => Some (N0, NPEpow e2 (Npos p)) - end - else None - end. - - Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. - Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - - Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) - ARth.(ARmul_comm) ARth.(ARmul_assoc)). - - Lemma isIn_correct_aux : forall l e1 e2 p1 p2, - match - (if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with - | Zpos p => Some (Npos p, PEc cI) - | Z0 => Some (N0, PEc cI) - | Zneg p => Some (N0, NPEpow e2 (Npos p)) - end - else None) - with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == - NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ - (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. - intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); - case (PExpr_eq e1 e2); simpl; auto; intros H. - case_eq ((p1 ?= p2)%positive Eq);intros;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). - rewrite (Pcompare_Eq_eq _ _ H0). - rewrite H by trivial. ring [ (morph1 CRmorph)]. - fold (NPEpow e2 (Npos (p2 - p1))). - rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. split. 2:refine (refl_equal _). - rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. - change (ZtoN - match (p1 ?= p1 - p2)%positive Eq with - | Eq => 0 - | Lt => Zneg (p1 - p2 - p1) - | Gt => Zpos (p1 - (p1 - p2)) - end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))). - replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z. - split. - repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). - rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. - ring [ (morph1 CRmorph)]. - assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). - apply Zplus_gt_reg_l with (Zpos p2). - rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. - apply Zplus_gt_compat_r. refine (refl_equal _). - simpl;rewrite H0;trivial. -Qed. - -Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). -induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl. -ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. -Qed. - - -Theorem isIn_correct: forall l e1 p1 e2 p2, - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == - NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ - (Zpos p1 > NtoZ n)%Z - | _ => True - end. -Proof. -Opaque NPEpow. -intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; - try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. -generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. -destruct n. - simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. - generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5. - destruct n;simpl. - rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite pow_pos_mul. rewrite H1;rewrite H3. - assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == - pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * - NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. - rewrite <- pow_pos_plus. rewrite Pplus_minus. - split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite H2 in H1;simpl in H1. - assert (Zpos p1 > Zpos p6)%Z. - apply Zgt_trans with (Zpos p4). exact H4. exact H2. - unfold Zgt in H;simpl in H;rewrite H. - split. 2:exact H. - rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. - assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == - pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * - NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. - rewrite <- pow_pos_plus. - replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. - rewrite NPEmul_correct. simpl;ring. - assert - (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. - change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). - rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). - simpl. rewrite Pcompare_refl. simpl. reflexivity. - unfold Zminus, Zopp in H0. simpl in H0. - rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. - simpl. repeat rewrite pow_th.(rpow_pow_N). - intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. - rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. - rewrite pow_pos_mul. split. ring [H2]. exact H3. - generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3. - destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1]. - rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. - intros (H1, H2);rewrite H1;split. - unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. - simpl in H1;ring [H1]. trivial. - trivial. - destruct n. trivial. - generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. - destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. - intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial. - repeat rewrite pow_th.(rpow_pow_N). simpl. - intros (H1,H2);split;trivial. - rewrite pow_pos_pow_pos;trivial. - trivial. -Qed. - -Record rsplit : Type := mk_rsplit { - rsplit_left : PExpr C; - rsplit_common : PExpr C; - rsplit_right : PExpr C}. - -(* Stupid name clash *) -Notation left := rsplit_left. -Notation right := rsplit_right. -Notation common := rsplit_common. - -Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit := - match e1 with - | PEmul e3 e4 => - let r1 := split_aux e3 p e2 in - let r2 := split_aux e4 p (right r1) in - mk_rsplit (NPEmul (left r1) (left r2)) - (NPEmul (common r1) (common r2)) - (right r2) - | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 - | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 - | _ => - match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 - | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 - | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 - end - end. - -Lemma split_aux_correct_1 : forall l e1 p e2, - let res := match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 - | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 - | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 - end in - NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res)) - /\ - NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)). -Proof. - intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). - destruct (isIn e1 p e2 1). destruct p0. - Opaque NPEpow NPEmul. - destruct n;simpl; - (repeat rewrite NPEmul_correct;simpl; - repeat rewrite NPEpow_correct;simpl; - repeat rewrite pow_th.(rpow_pow_N);simpl). - intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. - intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H. - simpl in H;split;try ring [H]. - rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. - simpl;intros. repeat rewrite NPEmul_correct;simpl. - rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. -Qed. - -Theorem split_aux_correct: forall l e1 p e2, - NPEeval l (PEpow e1 (Npos p)) == - NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) -/\ - NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) - (common (split_aux e1 p e2))). -Proof. -intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. -generalize (IHe1_1 k e2); clear IHe1_1. -generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. -simpl. repeat (rewrite NPEmul_correct;simpl). -repeat rewrite pow_th.(rpow_pow_N);simpl. -intros (H1,H2) (H3,H4);split. -rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. -rewrite H4;rewrite H2;ring. -destruct n;simpl. -split. repeat rewrite pow_th.(rpow_pow_N);simpl. -rewrite NPEmul_correct. simpl. - induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)]. - rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)]. -generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl. -repeat rewrite NPEmul_correct;simpl. -repeat rewrite pow_th.(rpow_pow_N);simpl. -rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. -Qed. - -Definition split e1 e2 := split_aux e1 xH e2. - -Theorem split_correct_l: forall l e1 e2, - NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) - (common (split e1 e2))). -Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl. -rewrite pow_th.(rpow_pow_N);simpl;auto. -Qed. - -Theorem split_correct_r: forall l e1 e2, - NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) - (common (split e1 e2))). -Proof. -intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. -Qed. - -Fixpoint Fnorm (e : FExpr) : linear := - match e with - | FEc c => mk_linear (PEc c) (PEc cI) nil - | FEX x => mk_linear (PEX C x) (PEc cI) nil - | FEadd e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) - (NPEmul (left s) (NPEmul (right s) (common s))) - (condition x ++ condition y) - - | FEsub e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s := split (denum x) (denum y) in - mk_linear - (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) - (NPEmul (left s) (NPEmul (right s) (common s))) - (condition x ++ condition y) - | FEmul e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (denum y) in - let s2 := split (num y) (denum x) in - mk_linear (NPEmul (left s1) (left s2)) - (NPEmul (right s2) (right s1)) - (condition x ++ condition y) - | FEopp e1 => - let x := Fnorm e1 in - mk_linear (NPEopp (num x)) (denum x) (condition x) - | FEinv e1 => - let x := Fnorm e1 in - mk_linear (denum x) (num x) (num x :: condition x) - | FEdiv e1 e2 => - let x := Fnorm e1 in - let y := Fnorm e2 in - let s1 := split (num x) (num y) in - let s2 := split (denum x) (denum y) in - mk_linear (NPEmul (left s1) (right s2)) - (NPEmul (left s2) (right s1)) - (num y :: condition x ++ condition y) - | FEpow e1 n => - let x := Fnorm e1 in - mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x) - end. - - -(* Example *) -(* -Eval compute - in (Fnorm - (FEdiv - (FEc cI) - (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). -*) - - Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0. -Proof. - induction p;simpl. - intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). - apply IHp. - rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). - reflexivity. - rewrite H1. ring. rewrite Hp;ring. - intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). - reflexivity. rewrite Hp;ring. trivial. -Qed. - -Theorem Pcond_Fnorm: - forall l e, - PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. -intros l e; elim e. - simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. - simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; case Hrec1; auto. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; case Hrec2; auto. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; case Hrec1; auto. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; case Hrec2; auto. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; apply Hrec1. - apply PCond_app_inv_l with (1 := Hcond). - rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; apply Hrec2. - apply PCond_app_inv_r with (1 := Hcond). - rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros e1 Hrec1 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - auto. - intros e1 Hrec1 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - apply PCond_cons_inv_l with (1:=Hcond). - intros e1 Hrec1 e2 Hrec2 Hcond. - simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. - apply field_is_integral_domain. - intros HH; apply Hrec1. - specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. - apply PCond_app_inv_l with (1 := Hcond1). - rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - intros HH; apply PCond_cons_inv_l with (1:=Hcond). - rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))). - rewrite NPEmul_correct; simpl; rewrite HH; ring. - simpl;intros e1 Hrec1 n Hcond. - rewrite NPEpow_correct. - simpl;rewrite pow_th.(rpow_pow_N). - destruct n;simpl;intros. - apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto. -Qed. -Hint Resolve Pcond_Fnorm. - - -(*************************************************************************** - - Main theorem - - ***************************************************************************) - -Theorem Fnorm_FEeval_PEeval: - forall l fe, - PCond l (condition (Fnorm fe)) -> - FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)). -Proof. -intros l fe; elim fe; simpl. -intros c H; rewrite CRmorph.(morph1); apply rdiv1. -intros p H; rewrite CRmorph.(morph1); apply rdiv1. -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -rewrite NPEadd_correct; simpl. -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2; rewrite U1; rewrite U2. -apply rdiv2b; auto. - rewrite <- U1; auto. - rewrite <- U2; auto. - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -rewrite NPEsub_correct; simpl. -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2; rewrite U1; rewrite U2. -apply rdiv3b; auto. - rewrite <- U1; auto. - rewrite <- U2; auto. - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -repeat rewrite NPEmul_correct; simpl. -generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1))) - (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; - rewrite U4; simpl. -apply rdiv4b; auto. - rewrite <- U4; auto. - rewrite <- U2; auto. - -intros e1 He1 HH. -rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. - -intros e1 He1 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_cons_inv_r with ( 1 := HH ). -rewrite (He1 HH1); apply rdiv6; auto. -apply PCond_cons_inv_l with ( 1 := HH ). - -intros e1 He1 e2 He2 HH. -assert (HH1: PCond l (condition (Fnorm e1))). -apply PCond_app_inv_l with (condition (Fnorm e2)). -apply PCond_cons_inv_r with ( 1 := HH ). -assert (HH2: PCond l (condition (Fnorm e2))). -apply PCond_app_inv_r with (condition (Fnorm e1)). -apply PCond_cons_inv_r with ( 1 := HH ). -rewrite (He1 HH1); rewrite (He2 HH2). -repeat rewrite NPEmul_correct;simpl. -generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2))) - (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))) - (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) - (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). -repeat rewrite NPEmul_correct; simpl. -intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3; - rewrite U4; simpl. -apply rdiv7b; auto. - rewrite <- U3; auto. - rewrite <- U2; auto. -apply PCond_cons_inv_l with ( 1 := HH ). - rewrite <- U4; auto. - -intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1. -repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N). -rewrite He1';clear He1'. -destruct n;simpl. apply rdiv1. -generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1))) - (Pcond_Fnorm _ _ Hcond). -intros r r0 Hdiff;induction p;simpl. -repeat (rewrite <- rdiv4;trivial). -rewrite IHp. reflexivity. -apply pow_pos_not_0;trivial. -apply pow_pos_not_0;trivial. -intro Hp. apply (pow_pos_not_0 Hdiff p). -rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). - reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. -rewrite <- rdiv4;trivial. -rewrite IHp;reflexivity. -apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. -reflexivity. -Qed. - -Theorem Fnorm_crossproduct: - forall l fe1 fe2, - let nfe1 := Fnorm fe1 in - let nfe2 := Fnorm fe2 in - NPEeval l (PEmul (num nfe1) (denum nfe2)) == - NPEeval l (PEmul (num nfe2) (denum nfe1)) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. -rewrite Fnorm_FEeval_PEeval in |- * by - apply PCond_app_inv_l with (1 := Hcond). - rewrite Fnorm_FEeval_PEeval in |- * by - apply PCond_app_inv_r with (1 := Hcond). - apply cross_product_eq; trivial. - apply Pcond_Fnorm. - apply PCond_app_inv_l with (1 := Hcond). - apply Pcond_Fnorm. - apply PCond_app_inv_r with (1 := Hcond). -Qed. - -(* Correctness lemmas of reflexive tactics *) -Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow). -Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv). - -Theorem Fnorm_correct: - forall n l lpe fe, - Ninterp_PElist l lpe -> - Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true -> - PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. -intros n l lpe fe Hlpe H H1; - apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). -apply rdiv8; auto. -transitivity (NPEeval l (PEc cO)); auto. -rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto. -change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)). -apply (Peq_ok Rsth Reqe CRmorph);auto. -simpl. apply (morph0 CRmorph); auto. -Qed. - -(* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) -Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. - -Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. - -Theorem Field_rw_correct : - forall n lpe l, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply SRdiv_ext; - eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto. -Qed. - -Theorem Field_rw_pow_correct : - forall n lpe l, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall fe nfe, Fnorm fe = nfe -> - PCond l (condition nfe) -> - FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)). -Proof. - intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. - apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply SRdiv_ext; - eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto. -Qed. - -Theorem Field_correct : - forall n l lpe fe1 fe2, Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2))) - (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp. -apply Fnorm_crossproduct; trivial. -eapply (ring_correct Rsth Reqe ARth CRmorph); eauto. -Qed. - -(* simplify a field equation : generate the crossproduct and simplify - polynomials *) -Theorem Field_simplify_eq_old_correct : - forall l fe1 fe2 nfe1 nfe2, - Fnorm fe1 = nfe1 -> - Fnorm fe2 = nfe2 -> - NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) == - NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. -apply Fnorm_crossproduct; trivial. -match goal with - [ |- NPEeval l ?x == NPEeval l ?y] => - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) - end. -trivial. -Qed. - -Theorem Field_simplify_eq_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == - NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; - subst nfe1 nfe2 den lmp. -apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -rewrite <-( - let x := PEmul (num (Fnorm fe1)) - (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -rewrite <-( - let x := (PEmul (num (Fnorm fe2)) - (rsplit_left - (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod in |- *. -reflexivity. -Qed. - -Theorem Field_simplify_eq_pow_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == - NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> - PCond l (condition nfe1 ++ condition nfe2) -> - FEeval l fe1 == FEeval l fe2. -Proof. -intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; - subst nfe1 nfe2 den lmp. -apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. -rewrite <-( - let x := PEmul (num (Fnorm fe1)) - (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -rewrite <-( - let x := (PEmul (num (Fnorm fe2)) - (rsplit_left - (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. -simpl in Hcrossprod. -rewrite Hcrossprod in |- *. -reflexivity. -Qed. - -Theorem Field_simplify_eq_pow_in_correct : - forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> - forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_pow l np1 == - NPphi_pow l np2. -Proof. - intros. subst nfe1 nfe2 lmp np1 np2. - repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. - assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). - assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). - intro Heq;apply N1. - rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). - rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. - repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). - repeat rewrite <- ARth.(ARmul_assoc). - change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). - change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). - repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l. - rewrite <- split_correct_r. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. - ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. - ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. - rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (AFth.(AFdiv_def)). - repeat rewrite <- Fnorm_FEeval_PEeval ; trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). -Qed. - -Theorem Field_simplify_eq_in_correct : -forall n l lpe fe1 fe2, - Ninterp_PElist l lpe -> - forall lmp, Nmk_monpol_list lpe = lmp -> - forall nfe1, Fnorm fe1 = nfe1 -> - forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> - forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> - forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> - FEeval l fe1 == FEeval l fe2 -> - PCond l (condition nfe1 ++ condition nfe2) -> - NPphi_dev l np1 == - NPphi_dev l np2. -Proof. - intros. subst nfe1 nfe2 lmp np1 np2. - repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec). - repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. - assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). - assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). - intro Heq;apply N1. - rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). - rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. - repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))). - repeat rewrite <- ARth.(ARmul_assoc). - change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))). - change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with - (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))). - repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l. - rewrite <- split_correct_r. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial. - ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))). - intro Heq; apply AFth.(AF_1_neq_0). - rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial. - ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))). - repeat rewrite <- (ARth.(ARmul_assoc)). - repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial. - rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp. - rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). - repeat rewrite <- (AFth.(AFdiv_def)). - repeat rewrite <- Fnorm_FEeval_PEeval;trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). -Qed. - - -Section Fcons_impl. - -Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). - -Hypothesis PCond_fcons_inv : forall l a l1, - PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. - -Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - | nil => m - | cons a l1 => Fcons a (Fapp l1 m) - end. - -Lemma fcons_correct : forall l l1, - PCond l (Fapp l1 nil) -> PCond l l1. -induction l1; simpl in |- *; intros. - trivial. - elim PCond_fcons_inv with (1 := H); intros. - destruct l1; auto. -Qed. - -End Fcons_impl. - -Section Fcons_simpl. - -(* Some general simpifications of the condition: eliminate duplicates, - split multiplications *) - -Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) - end. - -Theorem PFcons_fcons_inv: - forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a l1; elim l1; simpl Fcons; auto. -simpl; auto. -intros a0 l0. -generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0). -intros H H0 H1; split; auto. -rewrite H; auto. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -intros H H0 H1; - assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). -split. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -apply H0. -generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -generalize Hp; case l0; simpl; intuition. -Qed. - -(* equality of normal forms rather than syntactic equality *) -Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := - match l with - nil => cons e nil - | cons a l1 => - if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) - end. - -Theorem PFcons0_fcons_inv: - forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a l1; elim l1; simpl Fcons0; auto. -simpl; auto. -intros a0 l0. -generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl. - case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)). -intros H H0 H1; split; auto. -rewrite H; auto. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -intros H H0 H1; - assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). -split. -generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. -apply H0. -generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -clear get_sign get_sign_spec. -generalize Hp; case l0; simpl; intuition. -Qed. - -Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) - | PEpow e1 _ => Fcons00 e1 l - | _ => Fcons0 e l - end. - -Theorem PFcons00_fcons_inv: - forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). - intros p H p0 H0 l1 H1. - simpl in H1. - case (H _ H1); intros H2 H3. - case (H0 _ H3); intros H4 H5; split; auto. - simpl in |- *. - apply field_is_integral_domain; trivial. - simpl;intros. rewrite pow_th.(rpow_pow_N). - destruct (H _ H0);split;auto. - destruct n;simpl. apply AFth.(AF_1_neq_0). - apply pow_pos_not_0;trivial. -Qed. - -Definition Pcond_simpl_gen := - fcons_correct _ PFcons00_fcons_inv. - - -(* Specific case when the equality test of coefs is complete w.r.t. the - field equality: non-zero coefs can be eliminated, and opposite can - be simplified (if -1 <> 0) *) - -Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true. - -Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type), - (phi c1 == phi c2 -> P x) -> - (~ phi c1 == phi c2 -> P y) -> - P (if ceqb c1 c2 then x else y). -Proof. -intros. -generalize (fun h => X (morph_eq CRmorph c1 c2 h)). -generalize (@ceqb_complete c1 c2). -case (c1 ?=! c2); auto; intros. -apply X0. -red in |- *; intro. -absurd (false = true); auto; discriminate. -Qed. - -Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := - match e with - PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l - | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l - | PEc c => if ceqb c cO then absurd_PCond else l - | _ => Fcons0 e l - end. - -Theorem PFcons1_fcons_inv: - forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). - simpl in |- *; intros c l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H0). - split; trivial. - rewrite <- (morph0 CRmorph) in |- *; trivial. - intros p H p0 H0 l1 H1. - simpl in H1. - case (H _ H1); intros H2 H3. - case (H0 _ H3); intros H4 H5; split; auto. - simpl in |- *. - apply field_is_integral_domain; trivial. - simpl in |- *; intros p H l1. - apply ceqb_rect_complete; intros. - elim (@absurd_PCond_bottom l H1). - destruct (H _ H1). - split; trivial. - apply ropp_neq_0; trivial. - rewrite (morph_opp CRmorph) in H0. - rewrite (morph1 CRmorph) in H0. - rewrite (morph0 CRmorph) in H0. - trivial. - intros;simpl. destruct (H _ H0);split;trivial. - rewrite pow_th.(rpow_pow_N). destruct n;simpl. - apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial. -Qed. - -Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. - -Theorem PFcons2_fcons_inv: - forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. -unfold Fcons2 in |- *; intros l a l1 H; split; - case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. -intros H1 H2 H3; case H1. -transitivity (NPEeval l a); trivial. -apply PExpr_simp_correct. -Qed. - -Definition Pcond_simpl_complete := - fcons_correct _ PFcons2_fcons_inv. - -End Fcons_simpl. - -End AlmostField. - -Section FieldAndSemiField. - - Record field_theory : Prop := mk_field { - F_R : ring_theory rO rI radd rmul rsub ropp req; - F_1_neq_0 : ~ 1 == 0; - Fdiv_def : forall p q, p / q == p * / q; - Finv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - - Definition F2AF f := - mk_afield - (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). - - Record semi_field_theory : Prop := mk_sfield { - SF_SR : semi_ring_theory rO rI radd rmul req; - SF_1_neq_0 : ~ 1 == 0; - SFdiv_def : forall p q, p / q == p * / q; - SFinv_l : forall p, ~ p == 0 -> / p * p == 1 - }. - -End FieldAndSemiField. - -End MakeFieldPol. - - Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth - (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := - mk_afield _ _ - (SRth_ARth Rsth sf.(SF_SR)) - sf.(SF_1_neq_0) - sf.(SFdiv_def) - sf.(SFinv_l). - - -Section Complete. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable (rdiv : R -> R -> R) (rinv : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). - Notation "x == y" := (req x y) (at level 70, no associativity). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid3. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. - -Section AlmostField. - - Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let ARth := AFth.(AF_AR). - Let rI_neq_rO := AFth.(AF_1_neq_0). - Let rdiv_def := AFth.(AFdiv_def). - Let rinv_l := AFth.(AFinv_l). - -Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. - -Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Lemma add_inj_r : forall p x y, - gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. -intros p x y. -elim p using Pind; simpl in |- *; intros. - apply S_inj; trivial. - apply H. - apply S_inj. - repeat rewrite (ARadd_assoc ARth) in |- *. - rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial. -Qed. - -Lemma gen_phiPOS_inj : forall x y, - gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> - x = y. -intros x y. -repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *. -ElimPcompare x y; intro. - intros. - apply Pcompare_Eq_eq; trivial. - intro. - elim gen_phiPOS_not_0 with (y - x)%positive. - apply add_inj_r with x. - symmetry in |- *. - rewrite (ARadd_0_r Rsth ARth) in |- *. - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. - rewrite Pplus_minus in |- *; trivial. - change Eq with (CompOpp Eq) in |- *. - rewrite <- Pcompare_antisym in |- *; trivial. - rewrite H in |- *; trivial. - intro. - elim gen_phiPOS_not_0 with (x - y)%positive. - apply add_inj_r with y. - rewrite (ARadd_0_r Rsth ARth) in |- *. - rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. - rewrite Pplus_minus in |- *; trivial. -Qed. - - -Lemma gen_phiN_inj : forall x y, - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - x = y. -destruct x; destruct y; simpl in |- *; intros; trivial. - elim gen_phiPOS_not_0 with p. - symmetry in |- *. - rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. - rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial. -Qed. - -Lemma gen_phiN_complete : forall x y, - gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> - Neq_bool x y = true. -intros. - replace y with x. - unfold Neq_bool in |- *. - rewrite Ncompare_refl in |- *; trivial. - apply gen_phiN_inj; trivial. -Qed. - -End AlmostField. - -Section Field. - - Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. - Let Rth := Fth.(F_R). - Let rI_neq_rO := Fth.(F_1_neq_0). - Let rdiv_def := Fth.(Fdiv_def). - Let rinv_l := Fth.(Finv_l). - Let AFth := F2AF Rsth Reqe Fth. - Let ARth := Rth_ARth Rsth Reqe Rth. - -Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y. -intros. -transitivity (x + (1 + - (1))). - rewrite (Ropp_def Rth) in |- *. - symmetry in |- *. - apply (ARadd_0_r Rsth ARth). - transitivity (y + (1 + - (1))). - repeat rewrite <- (ARplus_assoc ARth) in |- *. - repeat rewrite (ARadd_assoc ARth) in |- *. - apply (Radd_ext Reqe). - repeat rewrite <- (ARadd_comm ARth 1) in |- *. - trivial. - reflexivity. - rewrite (Ropp_def Rth) in |- *. - apply (ARadd_0_r Rsth ARth). -Qed. - - - Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. - -Let gen_phiPOS_inject := - gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. - -Lemma gen_phiPOS_discr_sgn : forall x y, - ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. -red in |- *; intros. -apply gen_phiPOS_not_0 with (y + x)%positive. -rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. -transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). - apply (Radd_ext Reqe); trivial. - reflexivity. - rewrite (same_gen Rsth Reqe ARth) in |- *. - rewrite (same_gen Rsth Reqe ARth) in |- *. - trivial. - apply (Ropp_def Rth). -Qed. - -Lemma gen_phiZ_inj : forall x y, - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - x = y. -destruct x; destruct y; simpl in |- *; intros. - trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - symmetry in |- *; trivial. - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite <- H in |- *. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - trivial. - rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial. - elim gen_phiPOS_discr_sgn with (1 := H). - elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite H in |- *. - apply (ARopp_zero Rsth Reqe ARth). - elim gen_phiPOS_discr_sgn with p0 p. - symmetry in |- *; trivial. - replace p0 with p; trivial. - apply gen_phiPOS_inject. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. - rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *. - rewrite H in |- *; trivial. - reflexivity. -Qed. - -Lemma gen_phiZ_complete : forall x y, - gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> - Zeq_bool x y = true. -intros. - replace y with x. - unfold Zeq_bool in |- *. - rewrite Zcompare_refl in |- *; trivial. - apply gen_phiZ_inj; trivial. -Qed. - -End Field. - -End Complete. diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v deleted file mode 100644 index e664b3b7..00000000 --- a/contrib/setoid_ring/InitialRing.v +++ /dev/null @@ -1,908 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import ZArith_base. -Require Import Zpow_def. -Require Import BinInt. -Require Import BinNat. -Require Import Setoid. -Require Import Ring_theory. -Require Import Ring_polynom. -Require Import ZOdiv_def. -Import List. - -Set Implicit Arguments. - -Import RingSyntax. - -(* An object to return when an expression is not recognized as a constant *) -Definition NotConstant := false. - -(** Z is a ring and a setoid*) - -Lemma Zsth : Setoid_Theory Z (@eq Z). -Proof (Eqsth Z). - -Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z). -Proof (Eq_ext Zplus Zmult Zopp). - -Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z). -Proof. - constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc. - exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc. - exact Zmult_plus_distr_l. trivial. exact Zminus_diag. -Qed. - -(** Two generic morphisms from Z to (abrbitrary) rings, *) -(**second one is more convenient for proofs but they are ext. equal*) -Section ZMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid3. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. - - Fixpoint gen_phiPOS1 (p:positive) : R := - match p with - | xH => 1 - | xO p => (1 + 1) * (gen_phiPOS1 p) - | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) - end. - - Fixpoint gen_phiPOS (p:positive) : R := - match p with - | xH => 1 - | xO xH => (1 + 1) - | xO p => (1 + 1) * (gen_phiPOS p) - | xI xH => 1 + (1 +1) - | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) - end. - - Definition gen_phiZ1 z := - match z with - | Zpos p => gen_phiPOS1 p - | Z0 => 0 - | Zneg p => -(gen_phiPOS1 p) - end. - - Definition gen_phiZ z := - match z with - | Zpos p => gen_phiPOS p - | Z0 => 0 - | Zneg p => -(gen_phiPOS p) - end. - Notation "[ x ]" := (gen_phiZ x). - - Definition get_signZ z := - match z with - | Zneg p => Some (Zpos p) - | _ => None - end. - - Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ. - Proof. - constructor. - destruct c;intros;try discriminate. - injection H;clear H;intros H1;subst c'. - simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. - Qed. - - - Section ALMOST_RING. - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. - Proof. - induction x;simpl. - rewrite IHx;destruct x;simpl;norm. - rewrite IHx;destruct x;simpl;norm. - rrefl. - Qed. - - Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x). - Proof. - induction x;simpl;norm. - rewrite IHx;norm. - add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_add : forall x y, - gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). - Proof. - induction x;destruct y;simpl;norm. - rewrite Pplus_carry_spec. - rewrite ARgen_phiPOS_Psucc. - rewrite IHx;norm. - add_push (gen_phiPOS1 y);add_push 1;rrefl. - rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl. - rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl. - add_push 1;rrefl. - rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl. - Qed. - - Lemma ARgen_phiPOS_mult : - forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. - Proof. - induction x;intros;simpl;norm. - rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. - rewrite IHx;rrefl. - Qed. - - End ALMOST_RING. - - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - Let ARth := Rth_ARth Rsth Reqe Rth. - Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - -(*morphisms are extensionaly equal*) - Lemma same_genZ : forall x, [x] == gen_phiZ1 x. - Proof. - destruct x;simpl; try rewrite (same_gen ARth);rrefl. - Qed. - - Lemma gen_Zeqb_ok : forall x y, - Zeq_bool x y = true -> [x] == [y]. - Proof. - intros x y H. - assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. - rewrite H1;rrefl. - Qed. - - Lemma gen_phiZ1_add_pos_neg : forall x y, - gen_phiZ1 - match (x ?= y)%positive Eq with - | Eq => Z0 - | Lt => Zneg (y - x) - | Gt => Zpos (x - y) - end - == gen_phiPOS1 x + -gen_phiPOS1 y. - Proof. - intros x y. - assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y). - generalize (Pminus_mask_Gt y x). - replace Eq with (CompOpp Eq);[intro H1;simpl|trivial]. - rewrite <- Pcompare_antisym in H1. - destruct ((x ?= y)%positive Eq). - rewrite H;trivial. rewrite (Ropp_def Rth);rrefl. - destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - rewrite (Ropp_def Rth);norm. - destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. - rewrite (ARgen_phiPOS_add ARth);simpl;norm. - add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm. - Qed. - - Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end - = match x with Eq => be | Lt => bg | Gt => bl end. - Proof. destruct x;simpl;intros;trivial. Qed. - - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - induction x;destruct y;simpl;norm. - apply (ARgen_phiPOS_add ARth). - apply gen_phiZ1_add_pos_neg. - replace Eq with (CompOpp Eq);trivial. - rewrite <- Pcompare_antisym;simpl. - rewrite match_compOpp. - rewrite (Radd_comm Rth). - apply gen_phiZ1_add_pos_neg. - rewrite (ARgen_phiPOS_add ARth); norm. - Qed. - - Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genZ. - destruct x;destruct y;simpl;norm; - rewrite (ARgen_phiPOS_mult ARth);try (norm;fail). - rewrite (Ropp_opp Rsth Reqe Rth);rrefl. - Qed. - - Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. - Proof. intros;subst;rrefl. Qed. - -(*proof that [.] satisfies morphism specifications*) - Lemma gen_phiZ_morph : - ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) - Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) - Zplus Zmult Zeq_bool gen_phiZ). - apply mkRmorph;simpl;try rrefl. - apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. - apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). - Qed. - -End ZMORPHISM. - -(** N is a semi-ring and a setoid*) -Lemma Nsth : Setoid_Theory N (@eq N). -Proof (Eqsth N). - -Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N). -Proof (Eq_s_ext Nplus Nmult). - -Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). -Proof. - constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. - exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. - exact Nmult_plus_distr_r. -Qed. - -Definition Nsub := SRsub Nplus. -Definition Nopp := (@SRopp N). - -Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). -Proof (SReqe_Reqe Nseqe). - -Lemma Nath : - almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). -Proof (SRth_ARth Nsth Nth). - -Definition Neq_bool (x y:N) := - match Ncompare x y with - | Eq => true - | _ => false - end. - -Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. - -Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. - -(**Same as above : definition of two,extensionaly equal, generic morphisms *) -(**from N to any semi-ring*) -Section NMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul: R->R->R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid4. - Ltac rrefl := gen_reflexivity Rsth. - Variable SReqe : sring_eq_ext radd rmul req. - Variable SRth : semi_ring_theory 0 1 radd rmul req. - Let ARth := SRth_ARth Rsth SRth. - Let Reqe := SReqe_Reqe SReqe. - Let ropp := (@SRopp R). - Let rsub := (@SRsub R radd). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext4. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext5. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - - Definition gen_phiN1 x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS1 1 radd rmul x - end. - - Definition gen_phiN x := - match x with - | N0 => 0 - | Npos x => gen_phiPOS 1 radd rmul x - end. - Notation "[ x ]" := (gen_phiN x). - - Lemma same_genN : forall x, [x] == gen_phiN1 x. - Proof. - destruct x;simpl. rrefl. - rewrite (same_gen Rsth Reqe ARth);rrefl. - Qed. - - Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_add Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. - Proof. - intros x y;repeat rewrite same_genN. - destruct x;destruct y;simpl;norm. - apply (ARgen_phiPOS_mult Rsth Reqe ARth). - Qed. - - Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y]. - Proof. exact gen_phiN_add. Qed. - -(*gen_phiN satisfies morphism specifications*) - Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req - N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN. - Proof. - constructor;intros;simpl; try rrefl. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - rewrite (Neq_bool_ok x y);trivial. rrefl. - Qed. - -End NMORPHISM. - -(* Words on N : initial structure for almost-rings. *) -Definition Nword := list N. -Definition NwO : Nword := nil. -Definition NwI : Nword := 1%N :: nil. - -Definition Nwcons n (w : Nword) : Nword := - match w, n with - | nil, 0%N => nil - | _, _ => n :: w - end. - -Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := - match w1, w2 with - | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' - | nil, _ => w2 - | _, nil => w1 - end. - -Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. - -Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). - -Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := - match w with - | m :: w' => (n*m)%N :: Nwscal n w' - | nil => nil - end. - -Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := - match w1 with - | 0%N::w1' => Nwopp (Nwmul w1' w2) - | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) - | nil => nil - end. -Fixpoint Nw_is0 (w : Nword) : bool := - match w with - | nil => true - | 0%N :: w' => Nw_is0 w' - | _ => false - end. - -Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := - match w1, w2 with - | n1::w1', n2::w2' => - if Neq_bool n1 n2 then Nweq_bool w1' w2' else false - | nil, _ => Nw_is0 w2 - | _, nil => Nw_is0 w1 - end. - -Section NWORDMORPHISM. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid5. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Fixpoint gen_phiNword (w : Nword) : R := - match w with - | nil => 0 - | n :: nil => gen_phiN rO rI radd rmul n - | N0 :: w' => - gen_phiNword w' - | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' - end. - - Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. -Proof. -induction w; simpl in |- *; intros; auto. - reflexivity. - - destruct a. - destruct w. - reflexivity. - - rewrite IHw in |- *; trivial. - apply (ARopp_zero Rsth Reqe ARth). - - discriminate. -Qed. - - Lemma gen_phiNword_cons : forall w n, - gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -induction w. - destruct n; simpl in |- *; norm. - - intros. - destruct n; norm. -Qed. - - Lemma gen_phiNword_Nwcons : forall w n, - gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -destruct w; intros. - destruct n; norm. - - unfold Nwcons in |- *. - rewrite gen_phiNword_cons in |- *. - reflexivity. -Qed. - - Lemma gen_phiNword_ok : forall w1 w2, - Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. -induction w1; intros. - simpl in |- *. - rewrite (gen_phiNword0_ok _ H) in |- *. - reflexivity. - - rewrite gen_phiNword_cons in |- *. - destruct w2. - simpl in H. - destruct a; try discriminate. - rewrite (gen_phiNword0_ok _ H) in |- *. - norm. - - simpl in H. - rewrite gen_phiNword_cons in |- *. - case_eq (Neq_bool a n); intros. - rewrite H0 in H. - rewrite <- (Neq_bool_ok _ _ H0) in |- *. - rewrite (IHw1 _ H) in |- *. - reflexivity. - - rewrite H0 in H; discriminate H. -Qed. - - -Lemma Nwadd_ok : forall x y, - gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. -induction x; intros. - simpl in |- *. - norm. - - destruct y. - simpl Nwadd; norm. - - simpl Nwadd in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by - (destruct Reqe; constructor; trivial). - - rewrite IHx in |- *. - norm. - add_push (- gen_phiNword x); reflexivity. -Qed. - -Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. -simpl in |- *. -unfold Nwopp in |- *; simpl in |- *. -intros. -rewrite gen_phiNword_Nwcons in |- *; norm. -Qed. - -Lemma Nwscal_ok : forall n x, - gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. -induction x; intros. - norm. - - simpl Nwscal in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- * - by (destruct Reqe; constructor; trivial). - - rewrite IHx in |- *. - norm. -Qed. - -Lemma Nwmul_ok : forall x y, - gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. -induction x; intros. - norm. - - destruct a. - simpl Nwmul in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. - norm. - - simpl Nwmul in |- *. - unfold Nwsub in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwscal_ok in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. - norm. -Qed. - -(* Proof that [.] satisfies morphism specifications *) - Lemma gen_phiNword_morph : - ring_morph 0 1 radd rmul rsub ropp req - NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. -constructor. - reflexivity. - - reflexivity. - - exact Nwadd_ok. - - intros. - unfold Nwsub in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwopp_ok in |- *. - norm. - - exact Nwmul_ok. - - exact Nwopp_ok. - - exact gen_phiNword_ok. -Qed. - -End NWORDMORPHISM. - -Section GEN_DIV. - - Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) - (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) - (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) - (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C) - (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R). - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - - (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - - Definition triv_div x y := - if ceqb x y then (cI, cO) - else (cO, x). - - Ltac Esimpl :=repeat (progress ( - match goal with - | |- context [phi cO] => rewrite (morph0 morph) - | |- context [phi cI] => rewrite (morph1 morph) - | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y) - | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y) - | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y) - | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x) - end)). - - Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div. - Proof. - constructor. - intros a b;unfold triv_div. - assert (X:= morph.(morph_eq) a b);destruct (ceqb a b). - Esimpl. - rewrite X; trivial. - rsimpl. - Esimpl; rsimpl. -Qed. - - Variable zphi : Z -> R. - - Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl. - Proof. - constructor. - intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst. - rewrite Zmult_comm; rsimpl. - Qed. - - Variable nphi : N -> R. - - Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl. - constructor. - intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst. - rewrite Nmult_comm; rsimpl. - Qed. - -End GEN_DIV. - - (* syntaxification of constants in an abstract ring: - the inverse of gen_phiPOS *) - Ltac inv_gen_phi_pos rI add mul t := - let rec inv_cst t := - match t with - rI => constr:1%positive - | (add rI rI) => constr:2%positive - | (add rI (add rI rI)) => constr:3%positive - | (mul (add rI rI) ?p) => (* 2p *) - match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) - | ?p => constr:(xO p) - end - | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) - match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant - | ?p => constr:(xI p) - end - | _ => constr:NotConstant - end in - inv_cst t. - -(* The (partial) inverse of gen_phiNword *) - Ltac inv_gen_phiNword rO rI add mul opp t := - match t with - rO => constr:NwO - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant - | ?p => constr:(Npos p::nil) - end - end. - - -(* The inverse of gen_phiN *) - Ltac inv_gen_phiN rO rI add mul t := - match t with - rO => constr:0%N - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant - | ?p => constr:(Npos p) - end - end. - -(* The inverse of gen_phiZ *) - Ltac inv_gen_phiZ rO rI add mul opp t := - match t with - rO => constr:0%Z - | (opp ?p) => - match inv_gen_phi_pos rI add mul p with - NotConstant => constr:NotConstant - | ?p => constr:(Zneg p) - end - | _ => - match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant - | ?p => constr:(Zpos p) - end - end. - -(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reifid constant - instead of resorting to the constant propagation of the simplification - algorithm. *) -Ltac inv_gen_phi rO rI cO cI t := - match t with - | rO => cO - | rI => cI - end. - -(* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:NotConstant. - -Ltac coerce_to_almost_ring set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) - | almost_ring_theory _ _ _ _ _ _ _ => rspec - | _ => fail 1 "not a valid ring theory" - end. - -Ltac coerce_to_ring_ext ext := - match type of ext with - | ring_eq_ext _ _ _ _ => ext - | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) - | _ => fail 1 "not a valid ring_eq_ext theory" - end. - -Ltac abstract_ring_morphism set ext rspec := - match type of rspec with - | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) - | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) - | almost_ring_theory _ _ _ _ _ _ _ => - constr:(gen_phiNword_morph set ext rspec) - | _ => fail 1 "bad ring structure" - end. - -Record hypo : Type := mkhypo { - hypo_type : Type; - hypo_proof : hypo_type - }. - -Ltac gen_ring_pow set arth pspec := - match pspec with - | None => - match type of arth with - | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => - constr:(mkhypo (@pow_N_th R rI rmul req set)) - | _ => fail 1 "gen_ring_pow" - end - | Some ?t => constr:(t) - end. - -Ltac gen_ring_sign morph sspec := - match sspec with - | None => - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => - constr:(mkhypo (@get_sign_None_th C copp ceqb)) - | _ => fail 2 "ring anomaly : default_sign_spec" - end - | Some ?t => constr:(t) - end. - -Ltac default_div_spec set reqe arth morph := - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ztriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ntriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (triv_div_th set reqe arth morph)) - | _ => fail 1 "ring anomaly : default_sign_spec" - end. - -Ltac gen_ring_div set reqe arth morph dspec := - match dspec with - | None => default_div_spec set reqe arth morph - | Some ?t => constr:(t) - end. - -Ltac ring_elements set ext rspec pspec sspec dspec rk := - let arth := coerce_to_almost_ring set ext rspec in - let ext_r := coerce_to_ring_ext ext in - let morph := - match rk with - | Abstract => abstract_ring_morphism set ext rspec - | @Computational ?reqb_ok => - match type of arth with - | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => - constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) - | _ => fail 2 "ring anomaly" - end - | @Morphism ?m => - match type of m with - | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m - | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => - constr:(SRmorph_Rmorph set m) - | _ => fail 2 "ring anomaly" - end - | _ => fail 1 "ill-formed ring kind" - end in - let p_spec := gen_ring_pow set arth pspec in - let s_spec := gen_ring_sign morph sspec in - let d_spec := gen_ring_div set ext_r arth morph dspec in - fun f => f arth ext_r morph p_spec s_spec d_spec. - -(* Given a ring structure and the kind of morphism, - returns 2 lemmas (one for ring, and one for ring_simplify). *) - - Ltac ring_lemmas set ext rspec pspec sspec dspec rk := - let gen_lemma2 := - match pspec with - | None => constr:(ring_rw_correct) - | Some _ => constr:(ring_rw_pow_correct) - end in - ring_elements set ext rspec pspec sspec dspec rk - ltac:(fun arth ext_r morph p_spec s_spec d_spec => - match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - let gen_lemma2_0 := - constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth - C c0 c1 cadd cmul csub copp ceq_b phi morph) in - match p_spec with - | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => - let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in - match d_spec with - | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => - let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in - match s_spec with - | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => - let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in - let lemma1 := - constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in - fun f => f arth ext_r morph lemma1 lemma2 - | _ => fail 4 "ring: bad sign specification" - end - | _ => fail 3 "ring: bad coefficiant division specification" - end - | _ => fail 2 "ring: bad power specification" - end - | _ => fail 1 "ring internal error: ring_lemmas, please report" - end). - -(* Tactic for constant *) -Ltac isnatcst t := - match t with - O => constr:true - | S ?p => isnatcst p - | _ => constr:false - end. - -Ltac isPcst t := - match t with - | xI ?p => isPcst p - | xO ?p => isPcst p - | xH => constr:true - (* nat -> positive *) - | P_of_succ_nat ?n => isnatcst n - | _ => constr:false - end. - -Ltac isNcst t := - match t with - N0 => constr:true - | Npos ?p => isPcst p - | _ => constr:false - end. - -Ltac isZcst t := - match t with - Z0 => constr:true - | Zpos ?p => isPcst p - | Zneg ?p => isPcst p - (* injection nat -> Z *) - | Z_of_nat ?n => isnatcst n - (* injection N -> Z *) - | Z_of_N ?n => isNcst n - (* *) - | _ => constr:false - end. - - - - - diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v deleted file mode 100644 index 0ba519fd..00000000 --- a/contrib/setoid_ring/NArithRing.v +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Export Ring. -Require Import BinPos BinNat. -Import InitialRing. - -Set Implicit Arguments. - -Ltac Ncst t := - match isNcst t with - true => t - | _ => constr:NotConstant - end. - -Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]). diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v deleted file mode 100644 index 60641bcf..00000000 --- a/contrib/setoid_ring/RealField.v +++ /dev/null @@ -1,134 +0,0 @@ -Require Import Nnat. -Require Import ArithRing. -Require Export Ring Field. -Require Import Rdefinitions. -Require Import Rpow_def. -Require Import Raxioms. - -Open Local Scope R_scope. - -Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). -Proof. -constructor. - intro; apply Rplus_0_l. - exact Rplus_comm. - symmetry in |- *; apply Rplus_assoc. - intro; apply Rmult_1_l. - exact Rmult_comm. - symmetry in |- *; apply Rmult_assoc. - intros m n p. - rewrite Rmult_comm in |- *. - rewrite (Rmult_comm n p) in |- *. - rewrite (Rmult_comm m p) in |- *. - apply Rmult_plus_distr_l. - reflexivity. - exact Rplus_opp_r. -Qed. - -Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). -Proof. -constructor. - exact RTheory. - exact R1_neq_R0. - reflexivity. - exact Rinv_l. -Qed. - -Lemma Rlt_n_Sn : forall x, x < x + 1. -Proof. -intro. -elim archimed with x; intros. -destruct H0. - apply Rlt_trans with (IZR (up x)); trivial. - replace (IZR (up x)) with (x + (IZR (up x) - x))%R. - apply Rplus_lt_compat_l; trivial. - unfold Rminus in |- *. - rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. - rewrite <- Rplus_assoc in |- *. - rewrite Rplus_opp_r in |- *. - apply Rplus_0_l. - elim H0. - unfold Rminus in |- *. - rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. - rewrite <- Rplus_assoc in |- *. - rewrite Rplus_opp_r in |- *. - rewrite Rplus_0_l in |- *; trivial. -Qed. - -Notation Rset := (Eqsth R). -Notation Rext := (Eq_ext Rplus Rmult Ropp). - -Lemma Rlt_0_2 : 0 < 2. -apply Rlt_trans with (0 + 1). - apply Rlt_n_Sn. - rewrite Rplus_comm in |- *. - apply Rplus_lt_compat_l. - replace 1 with (0 + 1). - apply Rlt_n_Sn. - apply Rplus_0_l. -Qed. - -Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. -unfold Rgt in |- *. -induction x; simpl in |- *; intros. - apply Rlt_trans with (1 + 0). - rewrite Rplus_comm in |- *. - apply Rlt_n_Sn. - apply Rplus_lt_compat_l. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. - apply Rmult_lt_compat_l. - apply Rlt_0_2. - trivial. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. - apply Rmult_lt_compat_l. - apply Rlt_0_2. - trivial. - replace 1 with (0 + 1). - apply Rlt_n_Sn. - apply Rplus_0_l. -Qed. - - -Lemma Rgen_phiPOS_not_0 : - forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. -red in |- *; intros. -specialize (Rgen_phiPOS x). -rewrite H in |- *; intro. -apply (Rlt_asym 0 0); trivial. -Qed. - -Lemma Zeq_bool_complete : forall x y, - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = - InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> - Zeq_bool x y = true. -Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. - -Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. -Proof. - intros x n; elim n; simpl in |- *; auto with real. - intros n0 H' m; rewrite H'; auto with real. -Qed. - -Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. -Proof. - constructor. destruct n. reflexivity. - simpl. induction p;simpl. - rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. - unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. - rewrite Rmult_comm;apply Rmult_1_l. -Qed. - -Ltac Rpow_tac t := - match isnatcst t with - | false => constr:(InitialRing.NotConstant) - | _ => constr:(N_of_nat t) - end. - -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - - diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v deleted file mode 100644 index d01b1625..00000000 --- a/contrib/setoid_ring/Ring.v +++ /dev/null @@ -1,44 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Bool. -Require Export Ring_theory. -Require Export Ring_base. -Require Export InitialRing. -Require Export Ring_tac. - -Lemma BoolTheory : - ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)). -split; simpl in |- *. -destruct x; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. -reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. -reflexivity. -destruct x; reflexivity. -Qed. - -Definition bool_eq (b1 b2:bool) := - if b1 then b2 else negb b2. - -Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. -destruct b1; destruct b2; auto. -Qed. - -Ltac bool_cst t := - let t := eval hnf in t in - match t with - true => constr:true - | false => constr:false - | _ => constr:NotConstant - end. - -Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v deleted file mode 100644 index 956a15fe..00000000 --- a/contrib/setoid_ring/Ring_base.v +++ /dev/null @@ -1,15 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* This module gathers the necessary base to build an instance of the - ring tactic. Abstract rings need more theory, depending on - ZArith_base. *) - -Require Export Ring_theory. -Require Export Ring_tac. -Require Import InitialRing. diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v deleted file mode 100644 index 945f6c68..00000000 --- a/contrib/setoid_ring/Ring_equiv.v +++ /dev/null @@ -1,74 +0,0 @@ -Require Import Setoid_ring_theory. -Require Import LegacyRing_theory. -Require Import Ring_theory. - -Set Implicit Arguments. - -Section Old2New. - -Variable A : Type. - -Variable Aplus : A -> A -> A. -Variable Amult : A -> A -> A. -Variable Aone : A. -Variable Azero : A. -Variable Aopp : A -> A. -Variable Aeq : A -> A -> bool. -Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. - -Let Aminus := fun x y => Aplus x (Aopp y). - -Lemma ring_equiv1 : - ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)). -Proof. -destruct R. -split; eauto. -Qed. - -End Old2New. - -Section New2OldRing. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)). - - Variable reqb : R -> R -> bool. - Variable reqb_ok : forall x y, reqb x y = true -> x = y. - - Lemma ring_equiv2 : - Ring_Theory radd rmul rI rO ropp reqb. -Proof. -elim Rth; intros; constructor; eauto. -intros. -apply reqb_ok. -destruct (reqb x y); trivial; intros. -elim H. -Qed. - - Definition default_eqb : R -> R -> bool := fun x y => false. - Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y. -Proof. -discriminate 1. -Qed. - -End New2OldRing. - -Section New2OldSemiRing. - Variable R : Type. - Variable (rO rI : R) (radd rmul: R->R->R). - Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)). - - Variable reqb : R -> R -> bool. - Variable reqb_ok : forall x y, reqb x y = true -> x = y. - - Lemma sring_equiv2 : - Semi_Ring_Theory radd rmul rI rO reqb. -Proof. -elim SRth; intros; constructor; eauto. -intros. -apply reqb_ok. -destruct (reqb x y); trivial; intros. -elim H. -Qed. - -End New2OldSemiRing. diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v deleted file mode 100644 index d8847036..00000000 --- a/contrib/setoid_ring/Ring_polynom.v +++ /dev/null @@ -1,1781 +0,0 @@ -(************************************************************************) -(* V * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. -Require Export Ring_theory. - -Open Local Scope positive_scope. -Import RingSyntax. - -Section MakeRingPol. - - (* Ring elements *) - Variable R:Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). - Variable req : R -> R -> Prop. - - (* Ring properties *) - Variable Rsth : Setoid_Theory R req. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - - (* Coefficients *) - Variable C: Type. - Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - Variable phi : C -> R. - Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - - (* Power coefficients *) - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - Variable pow_th : power_theory rI rmul req Cp_phi rpow. - - (* division is ok *) - Variable cdiv: C -> C -> C * C. - Variable div_th: div_theory req cadd cmul phi cdiv. - - - (* R notations *) - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - - (* C notations *) - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - - (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. - - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} - - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. - - Definition P0 := Pc cO. - Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := - match P, P' with - | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => - match Pcompare j j' Eq with - | Eq => Peq Q Q' - | _ => false - end - | PX P i Q, PX P' i' Q' => - match Pcompare i i' Eq with - | Eq => if Peq P P' then Peq Q Q' else false - | _ => false - end - | _, _ => false - end. - - Notation " P ?== P' " := (Peq P P'). - - Definition mkPinj j P := - match P with - | Pc _ => P - | Pinj j' Q => Pinj ((j + j'):positive) Q - | _ => Pinj j P - end. - - Definition mkPinj_pred j P:= - match j with - | xH => P - | xO j => Pinj (Pdouble_minus_one j) P - | xI j => Pinj (xO j) P - end. - - Definition mkPX P i Q := - match P with - | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q - | Pinj _ _ => PX P i Q - | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q - end. - - Definition mkXi i := PX P1 i P0. - - Definition mkX := mkXi 1. - - (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := - match P with - | Pc c => Pc (-! c) - | Pinj j Q => Pinj j (Popp Q) - | PX P i Q => PX (Popp P) i (Popp Q) - end. - - Notation "-- P" := (Popp P). - - (** Addition et subtraction *) - - Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c1 => Pc (c1 +! c) - | Pinj j Q => Pinj j (PaddC Q c) - | PX P i Q => PX P i (PaddC Q c) - end. - - Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c1 => Pc (c1 -! c) - | Pinj j Q => Pinj j (PsubC Q c) - | PX P i Q => PX P i (PsubC Q c) - end. - - Section PopI. - - Variable Pop : Pol -> Pol -> Pol. - Variable Q : Pol. - - Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PaddI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') - | xI j => PX P i (PaddI (xO j) Q') - end - end. - - Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := - match P with - | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pop (Pinj k Q') Q) - | Z0 => mkPinj j (Pop Q' Q) - | Zneg k => mkPinj j' (PsubI k Q') - end - | PX P i Q' => - match j with - | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') - | xI j => PX P i (PsubI (xO j) Q') - end - end. - - Variable P' : Pol. - - Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => PX P' i' P - | Pinj j Q' => - match j with - | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') - | xI j => PX P' i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PaddX k P) i Q' - end - end. - - Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => PX (--P') i' P - | Pinj j Q' => - match j with - | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') - | xI j => PX (--P') i' (Pinj (xO j) Q') - end - | PX P i Q' => - match ZPminus i i' with - | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' - | Z0 => mkPX (Pop P P') i Q' - | Zneg k => mkPX (PsubX k P) i Q' - end - end. - - - End PopI. - - Fixpoint Padd (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PaddC P c' - | Pinj j' Q' => PaddI Padd Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => - match j with - | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') - | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus i i' with - | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') - | Z0 => mkPX (Padd P P') i (Padd Q Q') - | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') - end - end - end. - Notation "P ++ P'" := (Padd P P'). - - Fixpoint Psub (P P': Pol) {struct P'} : Pol := - match P' with - | Pc c' => PsubC P c' - | Pinj j' Q' => PsubI Psub Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => - match j with - | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') - | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end - | PX P i Q => - match ZPminus i i' with - | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') - | Z0 => mkPX (Psub P P') i (Psub Q Q') - | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') - end - end - end. - Notation "P -- P'" := (Psub P P'). - - (** Multiplication *) - - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := - match P with - | Pc c' => Pc (c' *! c) - | Pinj j Q => mkPinj j (PmulC_aux Q c) - | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c) - end. - - Definition PmulC P c := - if c ?=! cO then P0 else - if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. - Variable Pmul : Pol -> Pol -> Pol. - Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := - match P with - | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => - match ZPminus j' j with - | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) - | Z0 => mkPinj j (Pmul Q' Q) - | Zneg k => mkPinj j' (PmulI k Q') - end - | PX P' i' Q' => - match j with - | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') - | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') - end - end. - - End PmulI. -(* A symmetric version of the multiplication *) - - Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := - match P'' with - | Pc c => PmulC P c - | Pinj j' Q' => PmulI Pmul Q' j' P - | PX P' i' Q' => - match P with - | Pc c => PmulC P'' c - | Pinj j Q => - let QQ' := - match j with - | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' - | xI j => Pmul (Pinj (xO j) Q) Q' - end in - mkPX (Pmul P P') i' QQ' - | PX P i Q=> - let QQ' := Pmul Q Q' in - let PQ' := PmulI Pmul Q' xH P in - let QP' := Pmul (mkPinj xH Q) P' in - let PP' := Pmul P P' in - (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' - end - end. - -(* Non symmetric *) -(* - Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := - match P' with - | Pc c' => PmulC P c' - | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => - (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) - end. - - Definition Pmul P P' := - match P with - | Pc c => PmulC P' c - | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => - (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') - end. -*) - Notation "P ** P'" := (Pmul P P'). - - Fixpoint Psquare (P:Pol) : Pol := - match P with - | Pc c => Pc (c *! c) - | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => - let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in - let Q2 := Psquare Q in - let P2 := Psquare P in - mkPX (mkPX P2 i P0 ++ twoPQ) i Q2 - end. - - (** Monomial **) - - Inductive Mon: Set := - mon0: Mon - | zmon: positive -> Mon -> Mon - | vmon: positive -> Mon -> Mon. - - Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := - match M with - mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi - end. - - Definition mkZmon j M := - match M with mon0 => mon0 | _ => zmon j M end. - - Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Ppred j) M end. - - Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 - | zmon j m => vmon i (zmon_pred j m) - | vmon i' m => vmon (i+i') m - end. - - Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol := - match P with - | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q) - | Pinj j1 P1 => - let (R,S) := CFactor P1 c in - (mkPinj j1 R, mkPinj j1 S) - | PX P1 i Q1 => - let (R1, S1) := CFactor P1 c in - let (R2, S2) := CFactor Q1 c in - (mkPX R1 i R2, mkPX S1 i S2) - end. - - Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := - match P, M with - _, mon0 => - if (ceqb c cI) then (Pc cO, P) else -(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *) - CFactor P c - | Pc _, _ => (P, Pc cO) - | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) Eq with - Eq => let (R,S) := MFactor P1 c M1 in - (mkPinj j1 R, mkPinj j1 S) - | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in - (mkPinj j1 R, mkPinj j1 S) - | Gt => (P, Pc cO) - end - | Pinj _ _, vmon _ _ => (P, Pc cO) - | PX P1 i Q1, zmon j M1 => - let M2 := zmon_pred j M1 in - let (R1, S1) := MFactor P1 c M in - let (R2, S2) := MFactor Q1 c M2 in - (mkPX R1 i R2, mkPX S1 i S2) - | PX P1 i Q1, vmon j M1 => - match (i ?= j) Eq with - Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, S1) - | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in - (mkPX R1 i Q1, S1) - | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in - (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) - end - end. - - Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := - let (c,M1) := cM1 in - let (Q1,R1) := MFactor P1 c M1 in - match R1 with - (Pc c) => if c ?=! cO then None - else Some (Padd Q1 (Pmul P2 R1)) - | _ => Some (Padd Q1 (Pmul P2 R1)) - end. - - Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end - | _ => P1 - end. - - Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with - Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end - | _ => None - end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: - Pol := - match LM1 with - cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n - | _ => P1 - end. - - Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := - match LM1 with - cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with - Some P3 => Some (PSubstL1 P3 LM2 n) - | None => PSubstL P1 LM2 n - end - | _ => None - end. - - Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := - match PSubstL P1 LM1 n with - Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end - | _ => P1 - end. - - (** Evaluation of a polynomial towards R *) - - Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) - end. - - Reserved Notation "P @ l " (at level 10, no associativity). - Notation "P @ l " := (Pphi l P). - (** Proofs *) - Lemma ZPminus_spec : forall x y, - match ZPminus x y with - | Z0 => x = y - | Zpos k => x = (y + k)%positive - | Zneg k => y = (x + k)%positive - end. - Proof. - induction x;destruct y. - replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - simpl;trivial. - replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. - replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - simpl;trivial. - Qed. - - Lemma Peq_ok : forall P P', - (P ?== P') = true -> forall l, P@l == P'@ l. - Proof. - induction P;destruct P';simpl;intros;try discriminate;trivial. - apply (morph_eq CRmorph);trivial. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite H1;trivial. clear H1. - assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); - destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] - |discriminate H]. - rewrite (H1 H);rewrite (H2 H);rrefl. - Qed. - - Lemma Pphi0 : forall l, P0@l == 0. - Proof. - intros;simpl;apply (morph0 CRmorph). - Qed. - - Lemma Pphi1 : forall l, P1@l == 1. - Proof. - intros;simpl;apply (morph1 CRmorph). - Qed. - - Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). - Proof. - intros j l p;destruct p;simpl;rsimpl. - rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. - Qed. - - Let pow_pos_Pplus := - pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). - - Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). - Proof. - intros l P i Q;unfold mkPX. - destruct P;try (simpl;rrefl). - assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. - rewrite (H (refl_equal true));rewrite (morph0 CRmorph). - rewrite mkPinj_ok;rsimpl;simpl;rrefl. - assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. - rewrite (H (refl_equal true));trivial. - rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. - Qed. - - Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [?P@?l] => - match P with - | P0 => rewrite (Pphi0 l) - | P1 => rewrite (Pphi1 l) - | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P) - | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q) - end - | |- context [[?c]] => - match c with - | cO => rewrite (morph0 CRmorph) - | cI => rewrite (morph1 CRmorph) - | ?x +! ?y => rewrite ((morph_add CRmorph) x y) - | ?x *! ?y => rewrite ((morph_mul CRmorph) x y) - | ?x -! ?y => rewrite ((morph_sub CRmorph) x y) - | -! ?x => rewrite ((morph_opp CRmorph) x) - end - end)); - rsimpl; simpl. - - Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. - Qed. - - Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. - Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. - Qed. - - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. - Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1;rewrite IHP2;rsimpl. - mul_push ([c]);rrefl. - Qed. - - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. - Proof. - intros c P l; unfold PmulC. - assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). - rewrite (H (refl_equal true));Esimpl. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - apply PmulC_aux_ok. - Qed. - - Lemma Popp_ok : forall P l, (--P)@l == - P@l. - Proof. - induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1;rewrite IHP2;rsimpl. - Qed. - - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) - | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - - Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. - Proof. - induction P';simpl;intros;Esimpl2. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rrefl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - Esimpl2;add_push [c];rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl. - rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_comm ARth). - destruct p2;simpl;try apply (ARadd_comm ARth). - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. - rewrite IHP'1;simpl;Esimpl. - rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - Qed. - - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. - Proof. - induction P';simpl;intros;Esimpl2;trivial. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. - add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. - rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. - destruct p2;simpl;rewrite Popp_ok;rsimpl. - apply (ARadd_comm ARth);trivial. - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial. - apply (ARadd_comm ARth);trivial. - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. - rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - Qed. -(* Proof for the symmetriv version *) - - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - -(* - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). - Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. - Qed. - - Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. - Proof. - induction P';simpl;intros. - Esimpl2;trivial. - apply PmulI_ok;trivial. - rewrite Padd_ok;Esimpl2. - rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. - Qed. -*) - -(* Proof for the symmetric version *) - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - intros P P';generalize P;clear P;induction P';simpl;intros. - apply PmulC_ok. apply PmulI_ok;trivial. - destruct P. - rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. - Esimpl2. rewrite IHP'1;Esimpl2. - assert (match p0 with - | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 - | 1 => P ** P'2 - end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). - destruct p0;simpl;rewrite IHP'2;Esimpl. - rewrite jump_Pdouble_minus_one;Esimpl. - rewrite H;Esimpl. - rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. - repeat (rewrite IHP'1 || rewrite IHP'2);simpl. - rewrite PmulI_ok;trivial. - mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl. - Qed. - -(* -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. - Proof. - destruct P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_comm ARth). - rewrite Padd_ok; Esimpl2. - rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. - rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_comm ARth (P' @ l));rrefl. - Qed. -*) - - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. - Proof. - induction P;simpl;intros;Esimpl2. - apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. - rewrite IHP1;rewrite IHP2. - mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). - rrefl. - Qed. - - - Lemma mkZmon_ok: forall M j l, - Mphi l (mkZmon j M) == Mphi l (zmon j M). - intros M j l; case M; simpl; intros; rsimpl. - Qed. - - Lemma zmon_pred_ok : forall M j l, - Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). - Proof. - destruct j; simpl;intros auto; rsimpl. - rewrite mkZmon_ok;rsimpl. - rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl. - Qed. - - Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. - Proof. - destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. - Qed. - - Lemma Mcphi_ok: forall P c l, - let (Q,R) := CFactor P c in - P@l == Q@l + (phi c) * (R@l). - Proof. - intros P; elim P; simpl; auto; clear P. - intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv. - intros q r H; rewrite H. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros i P Hrec c l. - generalize (Hrec c (jump i l)); case CFactor. - intros R1 S1; Esimpl; auto. - intros Q1 Qrec i R1 Rrec c l. - generalize (Qrec c l); case CFactor; intros S1 S2 HS. - generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1. - rewrite HS; rewrite HS1; Esimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - Qed. - - Lemma Mphi_ok: forall P (cM: C * Mon) l, - let (c,M) := cM in - let (Q,R) := MFactor P c M in - P@l == Q@l + (phi c) * (Mphi l M) * (R@l). - Proof. - intros P; elim P; simpl; auto; clear P. - intros c (c1, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - try rewrite (morph0 CRmorph); rsimpl. - generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1). - intros q r H; rewrite H; clear H H1. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros p m; Esimpl. - intros p m; Esimpl. - intros i P Hrec (c,M) l; case M; simpl; clear M. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P c (jump i l)); case CFactor. - intros R1 Q1 HH; rewrite HH; Esimpl. - intros j M. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); - simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); - case (MFactor P c (zmon (j -i) M)); simpl. - intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). - rewrite Pplus_comm; rewrite jump_Pplus; auto. - rewrite (morph0 CRmorph); rsimpl. - intros P2 m; rewrite (morph0 CRmorph); rsimpl. - - intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P2 c l); case CFactor. - intros S1 S2 HS. - generalize (Mcphi_ok Q2 c (tail l)); case CFactor. - intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1. - rsimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros j M1. - generalize (Hrec1 (c,zmon j M1) l); - case (MFactor P2 c (zmon j M1)). - intros R1 S1 H1. - generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); - case (MFactor Q2 c (zmon_pred j M1)); simpl. - intros R2 S2 H2; rewrite H1; rewrite H2. - repeat rewrite mkPX_ok; simpl. - rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - rewrite zmon_pred_ok;rsimpl. - intros j M1. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite mkZmon_ok. - apply rmul_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (c, vmon (j - i) M1) l); - case (MFactor P2 c (vmon (j - i) M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (c, mkZmon 1 M1) l); - case (MFactor P2 c (mkZmon 1 M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite mkZmon_ok. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - rewrite mkPX_ok; simpl; rsimpl. - rewrite (morph0 CRmorph); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite (ARmul_comm ARth (Q3@l)); rsimpl. - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - repeat (rewrite <- (ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ He); rsimpl. - Qed. - -(* Proof for the symmetric version *) - - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l. - Proof. - intros P2 (cc,M1) P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - (* new version *) - rewrite Padd_ok; rewrite PmulC_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - assert (P4 = Q1 ++ P3 ** PX i P5 P6). - injection H2; intros; subst;trivial. - rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. - Qed. -(* - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. -Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok. - rewrite Pmul_ok; rsimpl. - Qed. -*) - Lemma PNSubst1_ok: forall n P1 M1 P2 l, - [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. - Proof. - intros n; elim n; simpl; auto. - intros P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. - intros n1 Hrec P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); - case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. - intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. - Qed. - - Lemma PNSubst_ok: forall n P1 M1 P2 l P3, - PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. - Proof. - intros n P2 (cc, M1) P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); - case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. - intros P5 H1; case n; try (intros; discriminate). - intros n1 H2; injection H2; intros; subst. - rewrite <- PNSubst1_ok; auto. - Qed. - - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) - | _ => True - end. - - Lemma PSubstL1_ok: forall n LM1 P1 l, - MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; rsimpl. - intros (M2,P2) LM2 Hrec P3 l [H H1]. - rewrite <- Hrec; auto. - apply PNSubst1_ok; auto. - Qed. - - Lemma PSubstL_ok: forall n LM1 P1 P2 l, - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. - Proof. - intros n LM1; elim LM1; simpl; auto. - intros; discriminate. - intros (M2,P2) LM2 Hrec P3 P4 l. - generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). - intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. - rewrite <- PSubstL1_ok; auto. - intros l1 H [H1 H2]; auto. - Qed. - - Lemma PNSubstL_ok: forall m n LM1 P1 l, - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. - Proof. - intros m; elim m; simpl; auto. - intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - intros m1 Hrec n LM1 P2 l H. - generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); - case (PSubstL P2 LM1 n); intros; rsimpl; auto. - rewrite <- Hrec; auto. - Qed. - - (** Definition of polynomial expressions *) - - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - - (** evaluation of polynomial expressions towards R *) - Definition mk_X j := mkPinj_pred j mkX. - - (** evaluation of polynomial expressions towards R *) - - Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R := - match pe with - | PEc c => phi c - | PEX j => nth 0 j l - | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) - | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) - | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) - | PEopp pe1 => - (PEeval l pe1) - | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) - end. - -Strategy expand [PEeval]. - - (** Correctness proofs *) - - Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. - Proof. - destruct p;simpl;intros;Esimpl;trivial. - rewrite <-jump_tl;rewrite nth_jump;rrefl. - rewrite <- nth_jump. - rewrite nth_Pdouble_minus_one;rrefl. - Qed. - - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). - -(* Power using the chinise algorithm *) -(*Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => P - | xO p => subst_l (Psquare (Ppow_pos P p)) - | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok P. - induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. - - End POWER. *) - -Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => subst_l (Pmul res P) - | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P1 P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. - rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed. - - End POWER. - - (** Normalization and rewriting *) - - Section NORM_SUBST_REC. - Variable n : nat. - Variable lmp:list (C*Mon*Pol). - Let subst_l P := PNSubstL P lmp n n. - Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). - Let Ppow_subst := Ppow_N subst_l. - - Fixpoint norm_aux (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) - | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n - end. - - Definition norm_subst pe := subst_l (norm_aux pe). - - (* - Fixpoint norm_subst (pe:PExpr) : Pol := - match pe with - | PEc c => Pc c - | PEX j => subst_l (mk_X j) - | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_subst pe1) (norm_subst pe2) - | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) - | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) - | PEopp pe1 => Popp (norm_subst pe1) - | PEpow pe1 n => Ppow_subst (norm_subst pe1) n - end. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). - unfold subst_l;intros. - rewrite <- PNSubstL_ok;trivial. rrefl. - assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). - intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. - induction pe;simpl;Esimpl3. - rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - unfold Ppow_subst. rewrite Ppow_N_ok. trivial. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - Qed. -*) - Lemma norm_aux_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_aux pe)@l. - Proof. - intros. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. - rewrite IHpe;rrefl. - rewrite Ppow_N_ok by (intros;rrefl). - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. - Qed. - - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. - Proof. - intros;unfold norm_subst. - unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. - Qed. - - End NORM_SUBST_REC. - - Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := - match lpe with - | nil => True - | (me,pe)::lpe => - match lpe with - | nil => PEeval l me == PEeval l pe - | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe - end - end. - - Fixpoint mon_of_pol (P:Pol) : option (C * Mon) := - match P with - | Pc c => if (c ?=! cO) then None else Some (c, mon0) - | Pinj j P => - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkZmon j m) - end - | PX P i Q => - if Peq Q P0 then - match mon_of_pol P with - | None => None - | Some (c,m) => Some (c, mkVmon i m) - end - else None - end. - - Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) := - match lpe with - | nil => nil - | (me,pe)::lpe => - match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe - end - end. - - Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> - forall l, [fst m] * Mphi l (snd m) == P@l. - Proof. - induction P;simpl;intros;Esimpl. - assert (H1 := (morph_eq CRmorph) c cO). - destruct (c ?=! cO). - discriminate. - inversion H;trivial;Esimpl. - generalize H;clear H;case_eq (mon_of_pol P). - intros (c1,P2) H0 H1; inversion H1; Esimpl. - generalize (IHP (c1, P2) H0 (jump p l)). - rewrite mkZmon_ok;simpl;auto. - intros; discriminate. - generalize H;clear H;change match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end with (P3 ?== P0). - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - case_eq (mon_of_pol P2);try intros (cc, pp); intros. - inversion H1. - simpl. - rewrite mkVmon_ok;simpl. - rewrite H;trivial;Esimpl. - generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl. - discriminate. - intros;discriminate. - Qed. - - Lemma interp_PElist_ok : forall l lpe, - interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. - Proof. - induction lpe;simpl. trivial. - destruct a;simpl;intros. - assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); - destruct (mon_of_pol (norm_subst 0 nil p)). - split. - rewrite <- norm_subst_spec by exact I. - destruct lpe;try destruct H;rewrite <- H; - rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. - Qed. - - Lemma norm_subst_ok : forall n l lpe pe, - interp_PElist l lpe -> - PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l. - Proof. - intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. - Qed. - - Lemma ring_correct : forall n l lpe pe1 pe2, - interp_PElist l lpe -> - (let lmp := mk_monpol_list lpe in - norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> - PEeval l pe1 == PEeval l pe2. - Proof. - simpl;intros. - do 2 (rewrite (norm_subst_ok n l lpe);trivial). - apply Peq_ok;trivial. - Qed. - - - - (** Generic evaluation of polynomial towards R avoiding parenthesis *) - Variable get_sign : C -> option C. - Variable get_sign_spec : sign_theory copp ceqb get_sign. - - - Section EVALUATION. - - (* [mkpow x p] = x^p *) - Variable mkpow : R -> positive -> R. - (* [mkpow x p] = -(x^p) *) - Variable mkopp_pow : R -> positive -> R. - (* [mkmult_pow r x p] = r * x^p *) - Variable mkmult_pow : R -> R -> positive -> R. - - Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := - match lm with - | nil => r - | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t - end. - - Definition mkmult1 lm := - match lm with - | nil => 1 - | cons (x,p) t => mkmult_rec (mkpow x p) t - end. - - Definition mkmultm1 lm := - match lm with - | nil => ropp rI - | cons (x,p) t => mkmult_rec (mkopp_pow x p) t - end. - - Definition mkmult_c_pos c lm := - if c ?=! cI then mkmult1 (rev' lm) - else mkmult_rec [c] (rev' lm). - - Definition mkmult_c c lm := - match get_sign c with - | None => mkmult_c_pos c lm - | Some c' => - if c' ?=! cI then mkmultm1 (rev' lm) - else mkmult_rec [c] (rev' lm) - end. - - Definition mkadd_mult rP c lm := - match get_sign c with - | None => rP + mkmult_c_pos c lm - | Some c' => rP - mkmult_c_pos c' lm - end. - - Definition add_pow_list (r:R) n l := - match n with - | N0 => l - | Npos p => (r,p)::l - end. - - Fixpoint add_mult_dev - (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := - match P with - | Pc c => - let lm := add_pow_list (hd 0 fv) n lm in - mkadd_mult rP c lm - | Pinj j Q => - add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => - let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) - end. - - Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) - (lm:list (R*positive)) {struct P} : R := - (* P@l * (hd 0 l)^n * lm *) - match P with - | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) - | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => - let rP := mult_dev P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else - let lmq := add_pow_list (hd 0 fv) n lm in - add_mult_dev rP Q (tail fv) N0 lmq - end. - - Definition Pphi_avoid fv P := mult_dev P fv N0 nil. - - Fixpoint r_list_pow (l:list (R*positive)) : R := - match l with - | nil => rI - | cons (r,p) l => pow_pos rmul r p * r_list_pow l - end. - - Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. - Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). - Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. - - Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. - Proof. - induction lm;intros;simpl;Esimpl. - destruct a as (x,p);Esimpl. - rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. - Qed. - - Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. - Proof. - destruct lm;simpl;Esimpl. - destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. - Qed. - - Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. - Proof. - destruct lm;simpl;Esimpl. - destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. - Qed. - - Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. - Proof. - assert - (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). - induction l;intros;simpl;Esimpl. - destruct a;rewrite IHl;Esimpl. - rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl. - intros;unfold rev'. rewrite H;simpl;Esimpl. - Qed. - - Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. - Proof. - intros;unfold mkmult_c_pos;simpl. - assert (H := (morph_eq CRmorph) c cI). - rewrite <- r_list_pow_rev; destruct (c ?=! cI). - rewrite H;trivial;Esimpl. - apply mkmult1_ok. apply mkmult_rec_ok. - Qed. - - Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. - Proof. - intros;unfold mkmult_c;simpl. - case_eq (get_sign c);intros. - assert (H1 := (morph_eq CRmorph) c0 cI). - destruct (c0 ?=! cI). - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial. - rewrite <- r_list_pow_rev;trivial;Esimpl. - apply mkmultm1_ok. - rewrite <- r_list_pow_rev; apply mkmult_rec_ok. - apply mkmult_c_pos_ok. -Qed. - - Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. - Proof. - intros;unfold mkadd_mult. - case_eq (get_sign c);intros. - rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl. - rewrite mkmult_c_pos_ok;Esimpl. - rewrite mkmult_c_pos_ok;Esimpl. - Qed. - - Lemma add_pow_list_ok : - forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. - Proof. - destruct n;simpl;intros;Esimpl. - Qed. - - Lemma add_mult_dev_ok : forall P rP fv n lm, - add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. - Proof. - induction P;simpl;intros. - rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. - rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (Nplus (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - rewrite IHP2. - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - Qed. - - Lemma mult_dev_ok : forall P fv n lm, - mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. - Proof. - induction P;simpl;intros;Esimpl. - rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. - rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. - change (match P3 with - | Pc c => c ?=! cO - | Pinj _ _ => false - | PX _ _ _ => false - end) with (Peq P3 P0). - change match n with - | N0 => Npos p - | Npos q => Npos (p + q) - end with (Nplus (Npos p) n);trivial. - assert (H := Peq_ok P3 P0). - destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. - destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - Qed. - - Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. - Proof. - unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl. - Qed. - - End EVALUATION. - - Definition Pphi_pow := - let mkpow x p := - match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in - let mkopp_pow x p := ropp (mkpow x p) in - let mkmult_pow r x p := rmul r (mkpow x p) in - Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma local_mkpow_ok : - forall (r : R) (p : positive), - match p with - | xI _ => rpow r (Cp_phi (Npos p)) - | xO _ => rpow r (Cp_phi (Npos p)) - | 1 => r - end == pow_pos rmul r p. - Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. - - Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. - Proof. - unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. - Qed. - - Lemma ring_rw_pow_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_pow l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1. - apply norm_subst_ok. trivial. - Qed. - - Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := - match p with - | xH => r*x - | xO p => mkmult_pow (mkmult_pow r x p) x p - | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p - end. - - Definition mkpow x p := - match p with - | xH => x - | xO p => mkmult_pow x x (Pdouble_minus_one p) - | xI p => mkmult_pow x x (xO p) - end. - - Definition mkopp_pow x p := - match p with - | xH => -x - | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) - | xI p => mkmult_pow (-x) x (xO p) - end. - - Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. - - Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. - Proof. - induction p;intros;simpl;Esimpl. - repeat rewrite IHp;Esimpl. - repeat rewrite IHp;Esimpl. - Qed. - - Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. - Proof. - destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. - Qed. - - Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. - Proof. - destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. - Qed. - - Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. - Proof. - unfold Pphi_dev;intros;apply Pphi_avoid_ok. - intros;apply mkpow_ok. - intros;apply mkopp_pow_ok. - intros;apply mkmult_pow_ok. - Qed. - - Lemma ring_rw_correct : forall n lH l, - interp_PElist l lH -> - forall lmp, mk_monpol_list lH = lmp -> - forall pe npe, norm_subst n lmp pe = npe -> - PEeval l pe == Pphi_dev l npe. - Proof. - intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1. - apply norm_subst_ok. trivial. - Qed. - - -End MakeRingPol. - diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v deleted file mode 100644 index ad20fa08..00000000 --- a/contrib/setoid_ring/Ring_tac.v +++ /dev/null @@ -1,386 +0,0 @@ -Set Implicit Arguments. -Require Import Setoid. -Require Import BinPos. -Require Import Ring_polynom. -Require Import BinList. -Require Import InitialRing. - - -(* adds a definition id' on the normal form of t and an hypothesis id - stating that t = id' (tries to produces a proof as small as possible) *) -Ltac compute_assertion id id' t := - let t' := eval vm_compute in t in - pose (id' := t'); - assert (id : t = id'); - [vm_cast_no_check (refl_equal id')|idtac]. -(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *) - -(********************************************************************) -(* Tacticals to build reflexive tactics *) - -Ltac OnEquation req := - match goal with - | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => fail 1 "Goal is not an equation (of expected equality)" - end. - -Ltac OnMainSubgoal H ty := - match ty with - | _ -> ?ty' => - let subtac := OnMainSubgoal H ty' in - fun tac => lapply H; [clear H; intro H; subtac tac | idtac] - | _ => (fun tac => tac) - end. - -Ltac ApplyLemmaThen lemma expr tac := - let nexpr := fresh "expr_nf" in - let H := fresh "eq_nf" in - let Heq := fresh "thm" in - let nf_spec := - match type of (lemma expr) with - forall x, ?nf_spec = x -> _ => nf_spec - | _ => fail 1 "ApplyLemmaThen: cannot find norm expression" - end in - compute_assertion H nexpr nf_spec; - assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"; - clear H; - OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr). - -Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg := - let npe := fresh "expr_nf" in - let H := fresh "eq_nf" in - let Heq := fresh "thm" in - let npe_spec := - match type of (lemma expr) with - forall npe, ?npe_spec = npe -> _ => npe_spec - | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression" - end in - (compute_assertion H npe npe_spec; - (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"); - clear H; - OnMainSubgoal Heq ltac:(type of Heq) - ltac:(try tac Heq; clear Heq npe;CONT_tac cont_arg)). - -(* General scheme of reflexive tactics using of correctness lemma - that involves normalisation of one expression *) - -Ltac ReflexiveRewriteTactic FV_tac SYN_tac MAIN_tac LEMMA_tac fv terms := - (* extend the atom list *) - let fv := list_fold_left FV_tac fv terms in - let RW_tac lemma := - let fcons term CONT_tac cont_arg := - let expr := SYN_tac term fv in - (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac cont_arg) in - (* rewrite steps *) - lazy_list_fold_right fcons ltac:(idtac) terms in - LEMMA_tac fv RW_tac. - -(********************************************************) - - -(* Building the atom list of a ring expression *) -Ltac FV Cst CstPow add mul sub opp pow t fv := - let rec TFV t fv := - match Cst t with - | NotConstant => - match t with - | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) - | (opp ?t1) => TFV t1 fv - | (pow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => AddFvTail t fv - | _ => TFV t1 fv - end - | _ => AddFvTail t fv - end - | _ => fv - end - in TFV t fv. - - (* syntaxification of ring expressions *) -Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := - let rec mkP t := - let f := - match Cst t with - | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEadd e1 e2) - | (rmul ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => - let e1 := mkP t1 in - let e2 := mkP t2 in constr:(PEsub e1 e2) - | (ropp ?t1) => - fun _ => - let e1 := mkP t1 in constr:(PEopp e1) - | (rpow ?t1 ?n) => - match CstPow n with - | InitialRing.NotConstant => - fun _ => let p := Find_at t fv in constr:(PEX C p) - | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) - end - | _ => - fun _ => let p := Find_at t fv in constr:(PEX C p) - end - | ?c => fun _ => constr:(@PEc C c) - end in - f () - in mkP t. - -Ltac ParseRingComponents lemma := - match type of lemma with - | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] => - (fun f => f R add mul sub opp pow C) - | _ => fail 1 "ring anomaly: bad correctness lemma (parse)" - end. - -(* ring tactics *) - -Ltac relation_carrier req := - let ty := type of req in - match eval hnf in ty with - ?R -> _ => R - | _ => fail 1000 "Equality has no relation type" - end. - -Ltac FV_hypo_tac mkFV req lH := - let R := relation_carrier req in - let FV_hypo_l_tac h := - match h with @mkhypo (req ?pe _) _ => mkFV pe end in - let FV_hypo_r_tac h := - match h with @mkhypo (req _ ?pe) _ => mkFV pe end in - let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in - list_fold_right FV_hypo_r_tac fv lH. - -Ltac mkHyp_tac C req mkPE lH := - let mkHyp h res := - match h with - | @mkhypo (req ?r1 ?r2) _ => - let pe1 := mkPE r1 in - let pe2 := mkPE r2 in - constr:(cons (pe1,pe2) res) - | _ => fail 1 "hypothesis is not a ring equality" - end in - list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH. - -Ltac proofHyp_tac lH := - let get_proof h := - match h with - | @mkhypo _ ?p => p - end in - let rec bh l := - match l with - | nil => constr:(I) - | cons ?h nil => get_proof h - | cons ?h ?tl => - let l := get_proof h in - let r := bh tl in - constr:(conj l r) - end in - bh lH. - -Definition ring_subst_niter := (10*10*10)%nat. - -Ltac Ring Cst_tac CstPow_tac lemma1 req n lH := - let Main lhs rhs R radd rmul rsub ropp rpow C := - let mkFV := FV Cst_tac CstPow_tac radd rmul rsub ropp rpow in - let mkPol := mkPolexpr C Cst_tac CstPow_tac radd rmul rsub ropp rpow in - let fv := FV_hypo_tac mkFV req lH in - let fv := mkFV lhs fv in - let fv := mkFV rhs fv in - check_fv fv; - let pe1 := mkPol lhs fv in - let pe2 := mkPol rhs fv in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in - let vlpe := fresh "hyp_list" in - let vfv := fresh "fv_list" in - pose (vlpe := lpe); - pose (vfv := fv); - (apply (lemma1 n vfv vlpe pe1 pe2) - || fail "typing error while applying ring"); - [ ((let prh := proofHyp_tac lH in exact prh) - || idtac "can not automatically proof hypothesis : maybe a left member of a hypothesis is not a monomial") - | vm_compute; - (exact (refl_equal true) || fail "not a valid ring equation")] in - ParseRingComponents lemma1 ltac:(OnEquation req Main). - -Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl := - let Main R add mul sub opp pow C := - let mkFV := FV Cst_tac CstPow_tac add mul sub opp pow in - let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in - let fv := FV_hypo_tac mkFV req lH in - let simpl_ring H := (protect_fv "ring" in H; f H) in - let lemma_tac fv RW_tac := - let rr_lemma := fresh "r_rw_lemma" in - let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in - let vlpe := fresh "list_hyp" in - let vlmp := fresh "list_hyp_norm" in - let vlmp_eq := fresh "list_hyp_norm_eq" in - let prh := proofHyp_tac lH in - pose (vlpe := lpe); - match type of lemma2 with - | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] - => - compute_assertion vlmp_eq vlmp - (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe); - (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq) - || fail 1 "type error when build the rewriting lemma"); - RW_tac rr_lemma; - try clear rr_lemma vlmp_eq vlmp vlpe - | _ => fail 1 "ring_simplify anomaly: bad correctness lemma" - end in - ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in - ParseRingComponents lemma2 Main. - - -Ltac Ring_gen - req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl := - pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH. - -Ltac Get_goal := match goal with [|- ?G] => G end. - -Tactic Notation (at level 0) "ring" := - let G := Get_goal in - ring_lookup Ring_gen [] G. - -Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := - let G := Get_goal in - ring_lookup Ring_gen [lH] G. - -(* Simplification *) - -Ltac Ring_simplify_gen f := - fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - let l := fresh "to_rewrite" in - pose (l:= rl); - generalize (refl_equal l); - unfold l at 2; - pre(); - let Tac RL := - let Heq := fresh "Heq" in - intros Heq;clear Heq l; - Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL; - post() in - let Main := - match goal with - | [|- l = ?RL -> _ ] => (fun f => f RL) - | _ => fail 1 "ring_simplify anomaly: bad goal after pre" - end in - Main Tac. - -Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). - -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := - let G := Get_goal in - ring_lookup Ring_simplify [] rl G. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - let G := Get_goal in - ring_lookup Ring_simplify [lH] rl G. - -(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) - -Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H;clear H; - ring_lookup Ring_simplify [] rl t; - intro H; - unfold g;clear g. - -Tactic Notation - "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= - let G := Get_goal in - let t := type of H in - let g := fresh "goal" in - set (g:= G); - generalize H;clear H; - ring_lookup Ring_simplify [lH] rl t; - intro H; - unfold g;clear g. - - - -(* LE RESTE MARCHE PAS DOMMAGE ..... *) - - - - - - - - - - - - - - - -(* - - - - - - - - -Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp). - - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := - match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl G end. - -Tactic Notation (at level 0) - "ring_simplify" constr_list(rl) := - match goal with [|- ?G] => ring_lookup Ring_simplify [] rl G end. - -Tactic Notation (at level 0) - "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):= - let t := type of h in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [lH] rl t. -(* ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *) - -Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp). - -Tactic Notation (at level 0) - "ring_simplify" constr_list(rl) "in" constr(h):= - let t := type of h in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [] rl t. - -Ltac rw_in H Heq := rewrite Heq in H. - -Ltac simpl_in H := - let t := type of H in - ring_lookup - (fun req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl => - pre(); - Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl; - post()) - [] t. - - -*) diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v deleted file mode 100644 index 531ab3ca..00000000 --- a/contrib/setoid_ring/Ring_theory.v +++ /dev/null @@ -1,608 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Setoid. -Require Import BinPos. -Require Import BinNat. - -Set Implicit Arguments. - -Module RingSyntax. -Reserved Notation "x ?=! y" (at level 70, no associativity). -Reserved Notation "x +! y " (at level 50, left associativity). -Reserved Notation "x -! y" (at level 50, left associativity). -Reserved Notation "x *! y" (at level 40, left associativity). -Reserved Notation "-! x" (at level 35, right associativity). - -Reserved Notation "[ x ]" (at level 0). - -Reserved Notation "x ?== y" (at level 70, no associativity). -Reserved Notation "x -- y" (at level 50, left associativity). -Reserved Notation "x ** y" (at level 40, left associativity). -Reserved Notation "-- x" (at level 35, right associativity). - -Reserved Notation "x == y" (at level 70, no associativity). -End RingSyntax. -Import RingSyntax. - -Section Power. - Variable R:Type. - Variable rI : R. - Variable rmul : R -> R -> R. - Variable req : R -> R -> Prop. - Variable Rsth : Setoid_Theory R req. - Notation "x * y " := (rmul x y). - Notation "x == y" := (req x y). - - Hypothesis mul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. - Hypothesis mul_comm : forall x y, x * y == y * x. - Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. - Add Setoid R req Rsth as R_set_Power. - Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed. - - - Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := - match i with - | xH => x - | xO i => let p := pow_pos x i in rmul p p - | xI i => let p := pow_pos x i in rmul x (rmul p p) - end. - - Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j. - Proof. - induction j;simpl. - rewrite IHj. - rewrite (mul_comm x (pow_pos x j *pow_pos x j)). - setoid_rewrite (mul_comm x (pow_pos x j)) at 2. - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - apply (Seq_refl _ _ Rsth). - Qed. - - Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. - Proof. - intro x;induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. - simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc; - simpl. apply (Seq_refl _ _ Rsth). - Qed. - - Definition pow_N (x:R) (p:N) := - match p with - | N0 => rI - | Npos p => pow_pos x p - end. - - Definition id_phi_N (x:N) : N := x. - - Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. - Proof. - intros; apply (Seq_refl _ _ Rsth). - Qed. - -End Power. - -Section DEFINITIONS. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - - (** Semi Ring *) - Record semi_ring_theory : Prop := mk_srt { - SRadd_0_l : forall n, 0 + n == n; - SRadd_comm : forall n m, n + m == m + n ; - SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; - SRmul_1_l : forall n, 1*n == n; - SRmul_0_l : forall n, 0*n == 0; - SRmul_comm : forall n m, n*m == m*n; - SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; - SRdistr_l : forall n m p, (n + m)*p == n*p + m*p - }. - - (** Almost Ring *) -(*Almost ring are no ring : Ropp_def is missing **) - Record almost_ring_theory : Prop := mk_art { - ARadd_0_l : forall x, 0 + x == x; - ARadd_comm : forall x y, x + y == y + x; - ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; - ARmul_1_l : forall x, 1 * x == x; - ARmul_0_l : forall x, 0 * x == 0; - ARmul_comm : forall x y, x * y == y * x; - ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - ARopp_mul_l : forall x y, -(x * y) == -x * y; - ARopp_add : forall x y, -(x + y) == -x + -y; - ARsub_def : forall x y, x - y == x + -y - }. - - (** Ring *) - Record ring_theory : Prop := mk_rt { - Radd_0_l : forall x, 0 + x == x; - Radd_comm : forall x y, x + y == y + x; - Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; - Rmul_1_l : forall x, 1 * x == x; - Rmul_comm : forall x y, x * y == y * x; - Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; - Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); - Rsub_def : forall x y, x - y == x + -y; - Ropp_def : forall x, x + (- x) == 0 - }. - - (** Equality is extensional *) - - Record sring_eq_ext : Prop := mk_seqe { - (* SRing operators are compatible with equality *) - SRadd_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SRmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2 - }. - - Record ring_eq_ext : Prop := mk_reqe { - (* Ring operators are compatible with equality *) - Radd_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - Rmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 - }. - - (** Interpretation morphisms definition*) - Section MORPHISM. - Variable C:Type. - Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. - (* [phi] est un morphisme de [C] dans [R] *) - Variable phi : C -> R. - Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). - Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - -(*for semi rings*) - Record semi_morph : Prop := mkRmorph { - Smorph0 : [cO] == 0; - Smorph1 : [cI] == 1; - Smorph_add : forall x y, [x +! y] == [x]+[y]; - Smorph_mul : forall x y, [x *! y] == [x]*[y]; - Smorph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - -(* for rings*) - Record ring_morph : Prop := mkmorph { - morph0 : [cO] == 0; - morph1 : [cI] == 1; - morph_add : forall x y, [x +! y] == [x]+[y]; - morph_sub : forall x y, [x -! y] == [x]-[y]; - morph_mul : forall x y, [x *! y] == [x]*[y]; - morph_opp : forall x, [-!x] == -[x]; - morph_eq : forall x y, x?=!y = true -> [x] == [y] - }. - - Section SIGN. - Variable get_sign : C -> option C. - Record sign_theory : Prop := mksign_th { - sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true - }. - End SIGN. - - Definition get_sign_None (c:C) := @None C. - - Lemma get_sign_None_th : sign_theory get_sign_None. - Proof. constructor;intros;discriminate. Qed. - - Section DIV. - Variable cdiv: C -> C -> C*C. - Record div_theory : Prop := mkdiv_th { - div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r] - }. - End DIV. - - End MORPHISM. - - (** Identity is a morphism *) - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid1. - Variable reqb : R->R->bool. - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - Definition IDphi (x:R) := x. - Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. - Proof. - apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi; - try apply (Seq_refl _ _ Rsth);auto. - Qed. - - (** Specification of the power function *) - Section POWER. - Variable Cpow : Set. - Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - - Record power_theory : Prop := mkpow_th { - rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) - }. - - End POWER. - - Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). - - -End DEFINITIONS. - - - -Section ALMOST_RING. - Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - - (** Leibniz equality leads to a setoid theory and is extensional*) - Lemma Eqsth : Setoid_Theory R (@eq R). - Proof. constructor;red;intros;subst;trivial. Qed. - - Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). - Proof. constructor;intros;subst;trivial. Qed. - - Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). - Proof. constructor;intros;subst;trivial. Qed. - - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid2. - Ltac sreflexivity := apply (Seq_refl _ _ Rsth). - - Section SEMI_RING. - Variable SReqe : sring_eq_ext radd rmul req. - Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. - Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed. - Variable SRth : semi_ring_theory 0 1 radd rmul req. - - (** Every semi ring can be seen as an almost ring, by taking : - -x = x and x - y = x + y *) - Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). - - Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). - - Lemma SRopp_ext : forall x y, x == y -> -x == -y. - Proof. intros x y H;exact H. Qed. - - Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. - Proof. - constructor. exact (SRadd_ext SReqe). exact (SRmul_ext SReqe). - exact SRopp_ext. - Qed. - - Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. - Proof. intros;sreflexivity. Qed. - - Lemma SRopp_add : forall x y, -(x + y) == -x + -y. - Proof. intros;sreflexivity. Qed. - - - Lemma SRsub_def : forall x y, x - y == x + -y. - Proof. intros;sreflexivity. Qed. - - Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. - Proof (mk_art 0 1 radd rmul SRsub SRopp req - (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) - (SRmul_1_l SRth) (SRmul_0_l SRth) - (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) - SRopp_mul_l SRopp_add SRsub_def). - - (** Identity morphism for semi-ring equipped with their almost-ring structure*) - Variable reqb : R->R->bool. - - Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. - - Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req - 0 1 radd rmul SRsub SRopp reqb (@IDphi R). - Proof. - apply mkmorph;intros;try sreflexivity. unfold IDphi;auto. - Qed. - - (* a semi_morph can be extended to a ring_morph for the almost_ring derived - from a semi_ring, provided the ring is a setoid (we only need - reflexivity) *) - Variable C : Type. - Variable (cO cI : C) (cadd cmul: C->C->C). - Variable (ceqb : C -> C -> bool). - Variable phi : C -> R. - Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi. - - Lemma SRmorph_Rmorph : - ring_morph rO rI radd rmul SRsub SRopp req - cO cI cadd cmul cadd (fun x => x) ceqb phi. - Proof. - case Smorph; intros; constructor; auto. - unfold SRopp in |- *; intros. - setoid_reflexivity. - Qed. - - End SEMI_RING. - - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. - - Section RING. - Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. - - (** Rings are almost rings*) - Lemma Rmul_0_l : forall x, 0 * x == 0. - Proof. - intro x; setoid_replace (0*x) with ((0+1)*x + -x). - rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth). - rewrite (Ropp_def Rth);sreflexivity. - - rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y. - Proof. - intros x y;rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_comm Rth). - rewrite <-(Ropp_def Rth (x*y)). - rewrite (Radd_assoc Rth). - rewrite <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). - rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Ropp_add : forall x y, -(x + y) == -x + -y. - Proof. - intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))). - rewrite <- ((Ropp_def Rth) x). - rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). - rewrite <- ((Ropp_def Rth) y). - rewrite ((Radd_comm Rth) x). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (-y)). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y). - rewrite <- ((Radd_assoc Rth) (- x)). - rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). - apply (Radd_comm Rth). - Qed. - - Lemma Ropp_opp : forall x, - -x == x. - Proof. - intros x; rewrite <- (Radd_0_l Rth (- -x)). - rewrite <- (Ropp_def Rth x). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth). - Qed. - - Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Proof - (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) - (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) - Ropp_mul_l Ropp_add (Rsub_def Rth)). - - (** Every semi morphism between two rings is a morphism*) - Variable C : Type. - Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). - Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). - Variable phi : C -> R. - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - Variable Csth : Setoid_Theory C ceq. - Variable Ceqe : ring_eq_ext cadd cmul copp ceq. - Add Setoid C ceq Csth as C_setoid. - Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. - Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed. - Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed. - Variable Cth : ring_theory cO cI cadd cmul csub copp ceq. - Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. - Variable phi_ext : forall x y, ceq x y -> [x] == [y]. - Add Morphism phi : phi_ext1. exact phi_ext. Qed. - Lemma Smorph_opp : forall x, [-!x] == -[x]. - Proof. - intros x;rewrite <- (Rth.(Radd_0_l) [-!x]). - rewrite <- ((Ropp_def Rth) [x]). - rewrite ((Radd_comm Rth) [x]). - rewrite <- (Radd_assoc Rth). - rewrite <- (Smorph_add Smorph). - rewrite (Ropp_def Cth). - rewrite (Smorph0 Smorph). - rewrite (Radd_comm Rth (-[x])). - apply (Radd_0_l Rth);sreflexivity. - Qed. - - Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. - Proof. - intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth). - rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. - Qed. - - Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. - Proof - (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi - (Smorph0 Smorph) (Smorph1 Smorph) - (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp - (Smorph_eq Smorph)). - - End RING. - - (** Useful lemmas on almost ring *) - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - - Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. -Proof. -elim ARth; intros. -constructor; trivial. -Qed. - - Lemma ARsub_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. - Proof. - intros. - setoid_replace (x1 - y1) with (x1 + -y1). - setoid_replace (x2 - y2) with (x2 + -y2). - rewrite H;rewrite H0;sreflexivity. - apply (ARsub_def ARth). - apply (ARsub_def ARth). - Qed. - Add Morphism rsub : rsub_ext. exact ARsub_ext. Qed. - - Ltac mrewrite := - repeat first - [ rewrite (ARadd_0_l ARth) - | rewrite <- ((ARadd_comm ARth) 0) - | rewrite (ARmul_1_l ARth) - | rewrite <- ((ARmul_comm ARth) 1) - | rewrite (ARmul_0_l ARth) - | rewrite <- ((ARmul_comm ARth) 0) - | rewrite (ARdistr_l ARth) - | sreflexivity - | match goal with - | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) - end]. - - Lemma ARadd_0_r : forall x, (x + 0) == x. - Proof. intros; mrewrite. Qed. - - Lemma ARmul_1_r : forall x, x * 1 == x. - Proof. intros;mrewrite. Qed. - - Lemma ARmul_0_r : forall x, x * 0 == 0. - Proof. intros;mrewrite. Qed. - - Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. - Proof. - intros;mrewrite. - repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. - Qed. - - Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x. - Proof. - intros;rewrite <-(ARth.(ARadd_assoc) x). - rewrite (ARth.(ARadd_comm) x);sreflexivity. - Qed. - - Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x. - Proof. - intros; repeat rewrite <- (ARadd_assoc ARth); - rewrite ((ARadd_comm ARth) x); sreflexivity. - Qed. - - Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x. - Proof. - intros;rewrite <-((ARmul_assoc ARth) x). - rewrite ((ARmul_comm ARth) x);sreflexivity. - Qed. - - Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. - Proof. - intros; repeat rewrite <- (ARmul_assoc ARth); - rewrite ((ARmul_comm ARth) x); sreflexivity. - Qed. - - Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. - Proof. - intros;rewrite ((ARmul_comm ARth) x y); - rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth). - Qed. - - Lemma ARopp_zero : -0 == 0. - Proof. - rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth). - repeat rewrite ARmul_0_r; sreflexivity. - Qed. - - - -End ALMOST_RING. - - -Section AddRing. - -(* Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. *) - -Inductive ring_kind : Type := -| Abstract -| Computational - (R:Type) - (req : R -> R -> Prop) - (reqb : R -> R -> bool) - (_ : forall x y, (reqb x y) = true -> req x y) -| Morphism - (R : Type) - (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) - (req : R -> R -> Prop) - (C : Type) - (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) - (ceqb : C->C->bool) - phi - (_ : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi). - - -End AddRing. - - -(** Some simplification tactics*) -Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). - -Ltac gen_srewrite Rsth Reqe ARth := - repeat first - [ gen_reflexivity Rsth - | progress rewrite (ARopp_zero Rsth Reqe ARth) - | rewrite (ARadd_0_l ARth) - | rewrite (ARadd_0_r Rsth ARth) - | rewrite (ARmul_1_l ARth) - | rewrite (ARmul_1_r Rsth ARth) - | rewrite (ARmul_0_l ARth) - | rewrite (ARmul_0_r Rsth ARth) - | rewrite (ARdistr_l ARth) - | rewrite (ARdistr_r Rsth Reqe ARth) - | rewrite (ARadd_assoc ARth) - | rewrite (ARmul_assoc ARth) - | progress rewrite (ARopp_add ARth) - | progress rewrite (ARsub_def ARth) - | progress rewrite <- (ARopp_mul_l ARth) - | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. - -Ltac gen_add_push add Rsth Reqe ARth x := - repeat (match goal with - | |- context [add (add ?y x) ?z] => - progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) - | |- context [add (add x ?y) ?z] => - progress rewrite (ARadd_assoc1 Rsth ARth x y z) - end). - -Ltac gen_mul_push mul Rsth Reqe ARth x := - repeat (match goal with - | |- context [mul (mul ?y x) ?z] => - progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) - | |- context [mul (mul x ?y) ?z] => - progress rewrite (ARmul_assoc1 Rsth ARth x y z) - end). - diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v deleted file mode 100644 index 942915ab..00000000 --- a/contrib/setoid_ring/ZArithRing.v +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Export Ring. -Require Import ZArith_base. -Require Import Zpow_def. - -Import InitialRing. - -Set Implicit Arguments. - -Ltac Zcst t := - match isZcst t with - true => t - | _ => constr:NotConstant - end. - -Ltac isZpow_coef t := - match t with - | Zpos ?p => isPcst p - | Z0 => constr:true - | _ => constr:false - end. - -Definition N_of_Z x := - match x with - | Zpos p => Npos p - | _ => N0 - end. - -Ltac Zpow_tac t := - match isZpow_coef t with - | true => constr:(N_of_Z t) - | _ => constr:NotConstant - end. - -Ltac Zpower_neg := - repeat match goal with - | [|- ?G] => - match G with - | context c [Zpower _ (Zneg _)] => - let t := context c [Z0] in - change t - end - end. - -Add Ring Zr : Zth - (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], - power_tac Zpower_theory [Zpow_tac], - (* The two following option are not needed, it is the default chose when the set of - coefficiant is usual ring Z *) - div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), - sign get_signZ_th). - - diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 deleted file mode 100644 index 50b7e47b..00000000 --- a/contrib/setoid_ring/newring.ml4 +++ /dev/null @@ -1,1172 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(*i $Id: newring.ml4 11800 2009-01-18 18:34:15Z msozeau $ i*) - -open Pp -open Util -open Names -open Term -open Closure -open Environ -open Libnames -open Tactics -open Rawterm -open Termops -open Tacticals -open Tacexpr -open Pcoq -open Tactic -open Constr -open Proof_type -open Coqlib -open Tacmach -open Mod_subst -open Tacinterp -open Libobject -open Printer -open Declare -open Decl_kinds -open Entries - -(****************************************************************************) -(* controlled reduction *) - -let mark_arg i c = mkEvar(i,[|c|]) -let unmark_arg f c = - match destEvar c with - | (i,[|c|]) -> f i c - | _ -> assert false - -type protect_flag = Eval|Prot|Rec - -let tag_arg tag_rec map subs i c = - match map i with - Eval -> mk_clos subs c - | Prot -> mk_atom c - | Rec -> if i = -1 then mk_clos subs c else tag_rec c - -let rec mk_clos_but f_map subs t = - match f_map t with - | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t - | None -> - (match kind_of_term t with - App(f,args) -> mk_clos_app_but f_map subs f args 0 - | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t - | _ -> mk_atom t) - -and mk_clos_app_but f_map subs f args n = - if n >= Array.length args then mk_atom(mkApp(f, args)) - else - let fargs, args' = array_chop n args in - let f' = mkApp(f,fargs) in - match f_map f' with - Some map -> - mk_clos_deep - (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) - subs - (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) - | None -> mk_clos_app_but f_map subs f args (n+1) - - -let interp_map l c = - try - let (im,am) = List.assoc c l in - Some(fun i -> - if List.mem i im then Eval - else if List.mem i am then Prot - else if i = -1 then Eval - else Rec) - with Not_found -> None - -let interp_map l t = - try Some(List.assoc t l) with Not_found -> None - -let protect_maps = ref ([]:(string*(constr->'a)) list) -let add_map s m = protect_maps := (s,m) :: !protect_maps -let lookup_map map = - try List.assoc map !protect_maps - with Not_found -> - errorlabstrm"lookup_map"(str"map "++qs map++str"not found") - -let protect_red map env sigma c = - kl (create_clos_infos betadeltaiota env) - (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);; - -let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; - -let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) - (Some((all_occurrences_expr,id),InHyp));; - - -TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> - [ protect_tac_in map id ] -| [ "protect_fv" string(map) ] -> - [ protect_tac map ] -END;; - -(****************************************************************************) - -let closed_term t l = - let l = List.map constr_of_global l in - let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in - if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) -;; - -TACTIC EXTEND closed_term - [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> - [ closed_term t l ] -END -;; - -TACTIC EXTEND echo -| [ "echo" constr(t) ] -> - [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] -END;; - -(* -let closed_term_ast l = - TacFun([Some(id_of_string"t")], - TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", - [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); - Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) -*) -let closed_term_ast l = - let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in - TacFun([Some(id_of_string"t")], - TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", - [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None); - Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) -(* -let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" -*) - -(****************************************************************************) - -let ic c = - let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c - -let ty c = Typing.type_of (Global.env()) Evd.empty c - -let decl_constant na c = - mkConst(declare_constant (id_of_string na) (DefinitionEntry - { const_entry_body = c; - const_entry_type = None; - const_entry_opaque = true; - const_entry_boxed = true}, - IsProof Lemma)) - -let ltac_call tac (args:glob_tactic_arg list) = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) -let ltac_acall tac (args:glob_tactic_arg list) = - TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args) - -let ltac_lcall tac args = - TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) - -let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) - -let dummy_goal env = - {Evd.it = Evd.make_evar (named_context_val env) mkProp; - Evd.sigma = Evd.empty} - -let exec_tactic env n f args = - let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in - let res = ref [||] in - let get_res ist = - let l = List.map (fun id -> List.assoc id ist.lfun) lid in - res := Array.of_list l; - TacId[] in - let getter = - Tacexp(TacFun(List.map(fun id -> Some id) lid, - glob_tactic(tacticIn get_res))) in - let _ = - Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in - !res - -let constr_of = function - | VConstr c -> c - | _ -> failwith "Ring.exec_tactic: anomaly" - -let stdlib_modules = - [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"]; - ["Coq";"Init";"Logic"]; - ] - -let coq_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) - -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_cons = coq_constant "cons" -let coq_nil = coq_constant "nil" -let coq_None = coq_constant "None" -let coq_Some = coq_constant "Some" -let coq_eq = coq_constant "eq" - -let lapp f args = mkApp(Lazy.force f,args) - -let dest_rel0 t = - match kind_of_term t with - | App(f,args) when Array.length args >= 2 -> - let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in - if closed0 rel then - (rel,args.(Array.length args - 2),args.(Array.length args - 1)) - else error "ring: cannot find relation (not closed)" - | _ -> error "ring: cannot find relation" - -let rec dest_rel t = - match kind_of_term t with - | Prod(_,_,c) -> dest_rel c - | _ -> dest_rel0 t - -(****************************************************************************) -(* Library linking *) - -let contrib_name = "setoid_ring" - -let cdir = ["Coq";contrib_name] -let contrib_modules = - List.map (fun d -> cdir@d) - [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; - ["Field_tac"]; ["Field_theory"] - ] - -let my_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c) - -let new_ring_path = - make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"]) -let ltac s = - lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) -let znew_ring_path = - make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"]) -let zltac s = - lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) - -let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; -let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;; - -(* Ring theory *) - -(* almost_ring defs *) -let coq_almost_ring_theory = my_constant "almost_ring_theory" - -(* setoid and morphism utilities *) -let coq_eq_setoid = my_constant "Eqsth" -let coq_eq_morph = my_constant "Eq_ext" -let coq_eq_smorph = my_constant "Eq_s_ext" - -(* ring -> almost_ring utilities *) -let coq_ring_theory = my_constant "ring_theory" -let coq_mk_reqe = my_constant "mk_reqe" - -(* semi_ring -> almost_ring utilities *) -let coq_semi_ring_theory = my_constant "semi_ring_theory" -let coq_mk_seqe = my_constant "mk_seqe" - -let ltac_inv_morph_gen = zltac"inv_gen_phi" -let ltac_inv_morphZ = zltac"inv_gen_phiZ" -let ltac_inv_morphN = zltac"inv_gen_phiN" -let ltac_inv_morphNword = zltac"inv_gen_phiNword" -let coq_abstract = my_constant"Abstract" -let coq_comp = my_constant"Computational" -let coq_morph = my_constant"Morphism" - -(* morphism *) -let coq_ring_morph = my_constant "ring_morph" -let coq_semi_morph = my_constant "semi_morph" - -(* power function *) -let ltac_inv_morph_nothing = zltac"inv_morph_nothing" -let coq_pow_N_pow_N = my_constant "pow_N_pow_N" - -(* hypothesis *) -let coq_mkhypo = my_constant "mkhypo" -let coq_hypo = my_constant "hypo" - -(* Equality: do not evaluate but make recursive call on both sides *) -let map_with_eq arg_map c = - let (req,_,_) = dest_rel c in - interp_map - ((req,(function -1->Prot|_->Rec)):: - List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) - -let _ = add_map "ring" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect - ring operations and make recursive call on the var map *) - pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring - operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) - -(****************************************************************************) -(* Ring database *) - -type ring_info = - { ring_carrier : types; - ring_req : constr; - ring_setoid : constr; - ring_ext : constr; - ring_morph : constr; - ring_th : constr; - ring_cst_tac : glob_tactic_expr; - ring_pow_tac : glob_tactic_expr; - ring_lemma1 : constr; - ring_lemma2 : constr; - ring_pre_tac : glob_tactic_expr; - ring_post_tac : glob_tactic_expr } - -module Cmap = Map.Make(struct type t = constr let compare = compare end) - -let from_carrier = ref Cmap.empty -let from_relation = ref Cmap.empty -let from_name = ref Spmap.empty - -let ring_for_carrier r = Cmap.find r !from_carrier -let ring_for_relation rel = Cmap.find rel !from_relation -let ring_lookup_by_name ref = - Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name - - -let find_ring_structure env sigma l oname = - match oname, l with - Some rf, _ -> - (try ring_lookup_by_name rf - with Not_found -> - errorlabstrm "ring" - (str "found no ring named "++pr_reference rf)) - | None, t::cl' -> - let ty = Retyping.get_type_of env sigma t in - let check c = - let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "ring" - (str"arguments of ring_simplify do not have all the same type") - in - List.iter check cl'; - (try ring_for_carrier ty - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> assert false -(* - let (req,_,_) = dest_rel cl in - (try ring_for_relation req - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) *) - -let _ = - Summary.declare_summary "tactic-new-ring-table" - { Summary.freeze_function = - (fun () -> !from_carrier,!from_relation,!from_name); - Summary.unfreeze_function = - (fun (ct,rt,nt) -> - from_carrier := ct; from_relation := rt; from_name := nt); - Summary.init_function = - (fun () -> - from_carrier := Cmap.empty; from_relation := Cmap.empty; - from_name := Spmap.empty); - Summary.survive_module = false; - Summary.survive_section = false } - -let add_entry (sp,_kn) e = -(* let _ = ty e.ring_lemma1 in - let _ = ty e.ring_lemma2 in -*) - from_carrier := Cmap.add e.ring_carrier e !from_carrier; - from_relation := Cmap.add e.ring_req e !from_relation; - from_name := Spmap.add sp e !from_name - - -let subst_th (_,subst,th) = - let c' = subst_mps subst th.ring_carrier in - let eq' = subst_mps subst th.ring_req in - let set' = subst_mps subst th.ring_setoid in - let ext' = subst_mps subst th.ring_ext in - let morph' = subst_mps subst th.ring_morph in - let th' = subst_mps subst th.ring_th in - let thm1' = subst_mps subst th.ring_lemma1 in - let thm2' = subst_mps subst th.ring_lemma2 in - let tac'= subst_tactic subst th.ring_cst_tac in - let pow_tac'= subst_tactic subst th.ring_pow_tac in - let pretac'= subst_tactic subst th.ring_pre_tac in - let posttac'= subst_tactic subst th.ring_post_tac in - if c' == th.ring_carrier && - eq' == th.ring_req && - set' = th.ring_setoid && - ext' == th.ring_ext && - morph' == th.ring_morph && - th' == th.ring_th && - thm1' == th.ring_lemma1 && - thm2' == th.ring_lemma2 && - tac' == th.ring_cst_tac && - pow_tac' == th.ring_pow_tac && - pretac' == th.ring_pre_tac && - posttac' == th.ring_post_tac then th - else - { ring_carrier = c'; - ring_req = eq'; - ring_setoid = set'; - ring_ext = ext'; - ring_morph = morph'; - ring_th = th'; - ring_cst_tac = tac'; - ring_pow_tac = pow_tac'; - ring_lemma1 = thm1'; - ring_lemma2 = thm2'; - ring_pre_tac = pretac'; - ring_post_tac = posttac' } - - -let (theory_to_obj, obj_to_theory) = - let cache_th (name,th) = add_entry name th - and export_th x = Some x in - declare_object - {(default_object "tactic-new-ring-theory") with - open_function = (fun i o -> if i=1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_th } - - -let setoid_of_relation env a r = - let evm = Evd.empty in - try - lapp coq_mk_Setoid - [|a ; r ; - Class_tactics.get_reflexive_proof env evm a r ; - Class_tactics.get_symmetric_proof env evm a r ; - Class_tactics.get_transitive_proof env evm a r |] - with Not_found -> - error "cannot find setoid relation" - -let op_morph r add mul opp req m1 m2 m3 = - lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] - -let op_smorph r add mul req m1 m2 = - lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] - -(* let default_ring_equality (r,add,mul,opp,req) = *) -(* let is_setoid = function *) -(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr req rel (\* Qu: use conversion ? *\) *) -(* | _ -> false in *) -(* match default_relation_for_carrier ~filter:is_setoid r with *) -(* Leibniz _ -> *) -(* let setoid = lapp coq_eq_setoid [|r|] in *) -(* let op_morph = *) -(* match opp with *) -(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) -(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) -(* (setoid,op_morph) *) -(* | Relation rel -> *) -(* let setoid = setoid_of_relation rel in *) -(* let is_endomorphism = function *) -(* { args=args } -> List.for_all *) -(* (function (var,Relation rel) -> *) -(* var=None && eq_constr req rel *) -(* | _ -> false) args in *) -(* let add_m = *) -(* try default_morphism ~filter:is_endomorphism add *) -(* with Not_found -> *) -(* error "ring addition should be declared as a morphism" in *) -(* let mul_m = *) -(* try default_morphism ~filter:is_endomorphism mul *) -(* with Not_found -> *) -(* error "ring multiplication should be declared as a morphism" in *) -(* let op_morph = *) -(* match opp with *) -(* | Some opp -> *) -(* (let opp_m = *) -(* try default_morphism ~filter:is_endomorphism opp *) -(* with Not_found -> *) -(* error "ring opposite should be declared as a morphism" in *) -(* let op_morph = *) -(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) -(* msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) -(* str"\""); *) -(* op_morph) *) -(* | None -> *) -(* (msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++ *) -(* pr_constr mul_m.morphism_theory++str"\""); *) -(* op_smorph r add mul req add_m.lem mul_m.lem) in *) -(* (setoid,op_morph) *) - -let ring_equality (r,add,mul,opp,req) = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - let setoid = lapp coq_eq_setoid [|r|] in - let op_morph = - match opp with - Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] - | None -> lapp coq_eq_smorph [|r;add;mul|] in - (setoid,op_morph) - | _ -> - let setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in - let add_m, add_m_lem = - try Class_tactics.default_morphism signature add - with Not_found -> - error "ring addition should be declared as a morphism" in - let mul_m, mul_m_lem = - try Class_tactics.default_morphism signature mul - with Not_found -> - error "ring multiplication should be declared as a morphism" in - let op_morph = - match opp with - | Some opp -> - (let opp_m,opp_m_lem = - try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (r,req))) opp - with Not_found -> - error "ring opposite should be declared as a morphism" in - let op_morph = - op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in - Flags.if_verbose - msgnl - (str"Using setoid \""++pr_constr req++str"\""++spc()++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\","++spc()++ str"\""++pr_constr mul_m_lem++ - str"\""++spc()++str"and \""++pr_constr opp_m_lem++ - str"\""); - op_morph) - | None -> - (Flags.if_verbose - msgnl - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\""++spc()++str"and \""++ - pr_constr mul_m_lem++str"\""); - op_smorph r add mul req add_m_lem mul_m_lem) in - (setoid,op_morph) - -let build_setoid_params r add mul opp req eqth = - match eqth with - Some th -> th - | None -> ring_equality (r,add,mul,opp,req) - -let dest_ring env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in - match kind_of_term th_typ with - App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when f = Lazy.force coq_almost_ring_theory -> - (None,r,zero,one,add,mul,Some sub,Some opp,req) - | App(f,[|r;zero;one;add;mul;req|]) - when f = Lazy.force coq_semi_ring_theory -> - (Some true,r,zero,one,add,mul,None,None,req) - | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when f = Lazy.force coq_ring_theory -> - (Some false,r,zero,one,add,mul,Some sub,Some opp,req) - | _ -> error "bad ring structure" - - -let dest_morph env sigma m_spec = - let m_typ = Retyping.get_type_of env sigma m_spec in - match kind_of_term m_typ with - App(f,[|r;zero;one;add;mul;sub;opp;req; - c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when f = Lazy.force coq_ring_morph -> - (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) - | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when f = Lazy.force coq_semi_morph -> - (c,czero,cone,cadd,cmul,None,None,ceqb,phi) - | _ -> error "bad morphism structure" - - -type coeff_spec = - Computational of constr (* equality test *) - | Abstract (* coeffs = Z *) - | Morphism of constr (* general morphism *) - - -let reflect_coeff rkind = - (* We build an ill-typed terms on purpose... *) - match rkind with - Abstract -> Lazy.force coq_abstract - | Computational c -> lapp coq_comp [|c|] - | Morphism m -> lapp coq_morph [|m|] - -type cst_tac_spec = - CstTac of raw_tactic_expr - | Closed of reference list - -let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = - match cst_tac with - Some (CstTac t) -> Tacinterp.glob_tactic t - | Some (Closed lc) -> - closed_term_ast (List.map Syntax_def.global_with_alias lc) - | None -> - (match rk, opp, kind with - Abstract, None, _ -> - let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) - | Abstract, Some opp, Some _ -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | Abstract, Some opp, None -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | Computational _,_,_ -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) - | Morphism mth,_,_ -> - let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in - TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) - -let make_hyp env c = - let t = Retyping.get_type_of env Evd.empty c in - lapp coq_mkhypo [|t;c|] - -let make_hyp_list env lH = - let carrier = Lazy.force coq_hypo in - List.fold_right - (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH - (lapp coq_nil [|carrier|]) - -let interp_power env pow = - let carrier = Lazy.force coq_hypo in - match pow with - | None -> - let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in - (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) - | Some (tac, spec) -> - let tac = - match tac with - | CstTac t -> Tacinterp.glob_tactic t - | Closed lc -> - closed_term_ast (List.map Syntax_def.global_with_alias lc) in - let spec = make_hyp env (ic spec) in - (tac, lapp coq_Some [|carrier; spec|]) - -let interp_sign env sign = - let carrier = Lazy.force coq_hypo in - match sign with - | None -> lapp coq_None [|carrier|] - | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] - (* Same remark on ill-typed terms ... *) - -let interp_div env div = - let carrier = Lazy.force coq_hypo in - match div with - | None -> lapp coq_None [|carrier|] - | Some spec -> - let spec = make_hyp env (ic spec) in - lapp coq_Some [|carrier;spec|] - (* Same remark on ill-typed terms ... *) - -let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = - check_required_library (cdir@["Ring_base"]); - let env = Global.env() in - let sigma = Evd.empty in - let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env div in - let rk = reflect_coeff morphth in - let params = - exec_tactic env 5 (zltac "ring_lemmas") - (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - - let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in - let cst_tac = - interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in - let pretac = - match pre with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let posttac = - match post with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let _ = - Lib.add_leaf name - (theory_to_obj - { ring_carrier = r; - ring_req = req; - ring_setoid = sth; - ring_ext = constr_of params.(1); - ring_morph = constr_of params.(2); - ring_th = constr_of params.(0); - ring_cst_tac = cst_tac; - ring_pow_tac = pow_tac; - ring_lemma1 = lemma1; - ring_lemma2 = lemma2; - ring_pre_tac = pretac; - ring_post_tac = posttac }) in - () - -type ring_mod = - Ring_kind of coeff_spec - | Const_tac of cst_tac_spec - | Pre_tac of raw_tactic_expr - | Post_tac of raw_tactic_expr - | Setoid of Topconstr.constr_expr * Topconstr.constr_expr - | Pow_spec of cst_tac_spec * Topconstr.constr_expr - (* Syntaxification tactic , correctness lemma *) - | Sign_spec of Topconstr.constr_expr - | Div_spec of Topconstr.constr_expr - - -VERNAC ARGUMENT EXTEND ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] - | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] - | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] - | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] - | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] - | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] - | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] - | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] - | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> - [ Pow_spec (Closed l, pow_spec) ] - | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> - [ Pow_spec (CstTac cst_tac, pow_spec) ] - | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] -END - -let set_once s r v = - if !r = None then r := Some v else error (s^" cannot be set twice") - -let process_ring_mods l = - let kind = ref None in - let set = ref None in - let cst_tac = ref None in - let pre = ref None in - let post = ref None in - let sign = ref None in - let power = ref None in - let div = ref None in - List.iter(function - Ring_kind k -> set_once "ring kind" kind k - | Const_tac t -> set_once "tactic recognizing constants" cst_tac t - | Pre_tac t -> set_once "preprocess tactic" pre t - | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) - | Pow_spec(t,spec) -> set_once "power" power (t,spec) - | Sign_spec t -> set_once "sign" sign t - | Div_spec t -> set_once "div" div t) l; - let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) - -VERNAC COMMAND EXTEND AddSetoidRing - | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory id (ic t) set k cst (pre,post) power sign div] -END - -(*****************************************************************************) -(* The tactics consist then only in a lookup in the ring database and - call the appropriate ltac. *) - -let make_args_list rl t = - match rl with - | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] - | _ -> rl - -let make_term_list carrier rl = - List.fold_right - (fun x l -> lapp coq_cons [|carrier;x;l|]) rl - (lapp coq_nil [|carrier|]) - - -let ring_lookup (f:glob_tactic_expr) lH rl t gl = - let env = pf_env gl in - let sigma = project gl in - let rl = make_args_list rl t in - let e = find_ring_structure env sigma rl None in - let rl = carg (make_term_list e.ring_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let req = carg e.ring_req in - let sth = carg e.ring_setoid in - let ext = carg e.ring_ext in - let morph = carg e.ring_morph in - let th = carg e.ring_th in - let cst_tac = Tacexp e.ring_cst_tac in - let pow_tac = Tacexp e.ring_pow_tac in - let lemma1 = carg e.ring_lemma1 in - let lemma2 = carg e.ring_lemma2 in - let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in - Tacinterp.eval_tactic - (TacLetIn - (false,[(dummy_loc,id_of_string"f"),Tacexp f], - ltac_lcall "f" - [req;sth;ext;morph;th;cst_tac;pow_tac; - lemma1;lemma2;pretac;posttac;lH;rl])) gl - -TACTIC EXTEND ring_lookup -| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t] -END - - - -(***********************************************************************) - -let new_field_path = - make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"]) - -let field_ltac s = - lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) - - -let _ = add_map "field" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* display_linear: evaluate polynomials and coef operations, protect - field operations and make recursive call on the var map *) - my_constant "display_linear", - (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); - my_constant "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect - ring operations and make recursive call on the var map *) - pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring - operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); - (* FEeval: evaluate morphism, protect field - operations and make recursive call on the var map *) - my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; - -let _ = add_map "field_cond" - (map_with_eq - [coq_cons,(function -1->Eval|2->Rec|_->Prot); - coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring - operations and make recursive call on the var map *) - my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);; -(* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*) - - -let afield_theory = my_constant "almost_field_theory" -let field_theory = my_constant "field_theory" -let sfield_theory = my_constant "semi_field_theory" -let af_ar = my_constant"AF_AR" -let f_r = my_constant"F_R" -let sf_sr = my_constant"SF_SR" -let dest_field env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in - match kind_of_term th_typ with - | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when f = Lazy.force afield_theory -> - let rth = lapp af_ar - [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in - (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) - | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when f = Lazy.force field_theory -> - let rth = - lapp f_r - [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in - (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) - | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when f = Lazy.force sfield_theory -> - let rth = lapp sf_sr - [|r;zero;one;add;mul;div;inv;req;th_spec|] in - (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) - | _ -> error "bad field structure" - -type field_info = - { field_carrier : types; - field_req : constr; - field_cst_tac : glob_tactic_expr; - field_pow_tac : glob_tactic_expr; - field_ok : constr; - field_simpl_eq_ok : constr; - field_simpl_ok : constr; - field_simpl_eq_in_ok : constr; - field_cond : constr; - field_pre_tac : glob_tactic_expr; - field_post_tac : glob_tactic_expr } - -let field_from_carrier = ref Cmap.empty -let field_from_relation = ref Cmap.empty -let field_from_name = ref Spmap.empty - - -let field_for_carrier r = Cmap.find r !field_from_carrier -let field_for_relation rel = Cmap.find rel !field_from_relation -let field_lookup_by_name ref = - Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) - !field_from_name - - -let find_field_structure env sigma l oname = - check_required_library (cdir@["Field_tac"]); - match oname, l with - Some rf, _ -> - (try field_lookup_by_name rf - with Not_found -> - errorlabstrm "field" - (str "found no field named "++pr_reference rf)) - | None, t::cl' -> - let ty = Retyping.get_type_of env sigma t in - let check c = - let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then - errorlabstrm "field" - (str"arguments of field_simplify do not have all the same type") - in - List.iter check cl'; - (try field_for_carrier ty - with Not_found -> - errorlabstrm "field" - (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) - | None, [] -> assert false -(* let (req,_,_) = dest_rel cl in - (try field_for_relation req - with Not_found -> - errorlabstrm "field" - (str"cannot find a declared field structure for equality"++ - spc()++str"\""++pr_constr req++str"\"")) *) - -let _ = - Summary.declare_summary "tactic-new-field-table" - { Summary.freeze_function = - (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); - Summary.unfreeze_function = - (fun (ct,rt,nt) -> - field_from_carrier := ct; field_from_relation := rt; - field_from_name := nt); - Summary.init_function = - (fun () -> - field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty; - field_from_name := Spmap.empty); - Summary.survive_module = false; - Summary.survive_section = false } - -let add_field_entry (sp,_kn) e = -(* - let _ = ty e.field_ok in - let _ = ty e.field_simpl_eq_ok in - let _ = ty e.field_simpl_ok in - let _ = ty e.field_cond in -*) - field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; - field_from_relation := Cmap.add e.field_req e !field_from_relation; - field_from_name := Spmap.add sp e !field_from_name - -let subst_th (_,subst,th) = - let c' = subst_mps subst th.field_carrier in - let eq' = subst_mps subst th.field_req in - let thm1' = subst_mps subst th.field_ok in - let thm2' = subst_mps subst th.field_simpl_eq_ok in - let thm3' = subst_mps subst th.field_simpl_ok in - let thm4' = subst_mps subst th.field_simpl_eq_in_ok in - let thm5' = subst_mps subst th.field_cond in - let tac'= subst_tactic subst th.field_cst_tac in - let pow_tac' = subst_tactic subst th.field_pow_tac in - let pretac'= subst_tactic subst th.field_pre_tac in - let posttac'= subst_tactic subst th.field_post_tac in - if c' == th.field_carrier && - eq' == th.field_req && - thm1' == th.field_ok && - thm2' == th.field_simpl_eq_ok && - thm3' == th.field_simpl_ok && - thm4' == th.field_simpl_eq_in_ok && - thm5' == th.field_cond && - tac' == th.field_cst_tac && - pow_tac' == th.field_pow_tac && - pretac' == th.field_pre_tac && - posttac' == th.field_post_tac then th - else - { field_carrier = c'; - field_req = eq'; - field_cst_tac = tac'; - field_pow_tac = pow_tac'; - field_ok = thm1'; - field_simpl_eq_ok = thm2'; - field_simpl_ok = thm3'; - field_simpl_eq_in_ok = thm4'; - field_cond = thm5'; - field_pre_tac = pretac'; - field_post_tac = posttac' } - -let (ftheory_to_obj, obj_to_ftheory) = - let cache_th (name,th) = add_field_entry name th - and export_th x = Some x in - declare_object - {(default_object "tactic-new-field-theory") with - open_function = (fun i o -> if i=1 then cache_th o); - cache_function = cache_th; - subst_function = subst_th; - classify_function = (fun (_,x) -> Substitute x); - export_function = export_th } - -let field_equality r inv req = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) -> - mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) - | _ -> - let _setoid = setoid_of_relation (Global.env ()) r req in - let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in - let inv_m, inv_m_lem = - try Class_tactics.default_morphism signature inv - with Not_found -> - error "field inverse should be declared as a morphism" in - inv_m_lem - -let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = - check_required_library (cdir@["Field_tac"]); - let env = Global.env() in - let sigma = Evd.empty in - let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env sigma fth in - let (sth,ext) = build_setoid_params r add mul opp req eqth in - let eqth = Some(sth,ext) in - let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env power in - let sspec = interp_sign env sign in - let dspec = interp_div env odiv in - let inv_m = field_equality r inv req in - let rk = reflect_coeff morphth in - let params = - exec_tactic env 9 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in - let lemma1 = constr_of params.(3) in - let lemma2 = constr_of params.(4) in - let lemma3 = constr_of params.(5) in - let lemma4 = constr_of params.(6) in - let cond_lemma = - match inj with - | Some thm -> mkApp(constr_of params.(8),[|thm|]) - | None -> constr_of params.(7) in - let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in - let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in - let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in - let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in - let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in - let cst_tac = - interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in - let pretac = - match pre with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let posttac = - match post with - Some t -> Tacinterp.glob_tactic t - | _ -> TacId [] in - let _ = - Lib.add_leaf name - (ftheory_to_obj - { field_carrier = r; - field_req = req; - field_cst_tac = cst_tac; - field_pow_tac = pow_tac; - field_ok = lemma1; - field_simpl_eq_ok = lemma2; - field_simpl_ok = lemma3; - field_simpl_eq_in_ok = lemma4; - field_cond = cond_lemma; - field_pre_tac = pretac; - field_post_tac = posttac }) in () - -type field_mod = - Ring_mod of ring_mod - | Inject of Topconstr.constr_expr - -VERNAC ARGUMENT EXTEND field_mod - | [ ring_mod(m) ] -> [ Ring_mod m ] - | [ "completeness" constr(inj) ] -> [ Inject inj ] -END - -let process_field_mods l = - let kind = ref None in - let set = ref None in - let cst_tac = ref None in - let pre = ref None in - let post = ref None in - let inj = ref None in - let sign = ref None in - let power = ref None in - let div = ref None in - List.iter(function - Ring_mod(Ring_kind k) -> set_once "field kind" kind k - | Ring_mod(Const_tac t) -> - set_once "tactic recognizing constants" cst_tac t - | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t - | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) - | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) - | Ring_mod(Sign_spec t) -> set_once "sign" sign t - | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic i)) l; - let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) - -VERNAC COMMAND EXTEND AddSetoidField -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in - add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] -END - -let field_lookup (f:glob_tactic_expr) lH rl t gl = - let env = pf_env gl in - let sigma = project gl in - let rl = make_args_list rl t in - let e = find_field_structure env sigma rl None in - let rl = carg (make_term_list e.field_carrier rl) in - let lH = carg (make_hyp_list env lH) in - let req = carg e.field_req in - let cst_tac = Tacexp e.field_cst_tac in - let pow_tac = Tacexp e.field_pow_tac in - let field_ok = carg e.field_ok in - let field_simpl_ok = carg e.field_simpl_ok in - let field_simpl_eq_ok = carg e.field_simpl_eq_ok in - let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in - let cond_ok = carg e.field_cond in - let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.field_post_tac)) in - Tacinterp.eval_tactic - (TacLetIn - (false,[(dummy_loc,id_of_string"f"),Tacexp f], - ltac_lcall "f" - [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; - field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl - -TACTIC EXTEND field_lookup -| [ "field_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] -END diff --git a/contrib/subtac/equations.ml4 b/contrib/subtac/equations.ml4 deleted file mode 100644 index 9d120019..00000000 --- a/contrib/subtac/equations.ml4 +++ /dev/null @@ -1,1149 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) - -(* $Id: subtac_cases.ml 11198 2008-07-01 17:03:43Z msozeau $ *) - -open Cases -open Util -open Names -open Nameops -open Term -open Termops -open Declarations -open Inductiveops -open Environ -open Sign -open Reductionops -open Typeops -open Type_errors - -open Rawterm -open Retyping -open Pretype_errors -open Evarutil -open Evarconv -open List -open Libnames - -type pat = - | PRel of int - | PCstr of constructor * pat list - | PInac of constr - -let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern") - -let mkInac env c = - mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |]) - -let rec constr_of_pat ?(inacc=true) env = function - | PRel i -> mkRel i - | PCstr (c, p) -> - let c' = mkConstruct c in - mkApp (c', Array.of_list (constrs_of_pats ~inacc env p)) - | PInac r -> - if inacc then try mkInac env r with _ -> r else r - -and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l - -let rec pat_vars = function - | PRel i -> Intset.singleton i - | PCstr (c, p) -> pats_vars p - | PInac _ -> Intset.empty - -and pats_vars l = - fold_left (fun vars p -> - let pvars = pat_vars p in - let inter = Intset.inter pvars vars in - if inter = Intset.empty then - Intset.union pvars vars - else error ("Non-linear pattern: variable " ^ - string_of_int (Intset.choose inter) ^ " appears twice")) - Intset.empty l - -let rec pats_of_constrs l = map pat_of_constr l -and pat_of_constr c = - match kind_of_term c with - | Rel i -> PRel i - | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) -> - PInac c - | App (f, args) when isConstruct f -> - PCstr (destConstruct f, pats_of_constrs (Array.to_list args)) - | Construct f -> PCstr (f, []) - | _ -> PInac c - -let inaccs_of_constrs l = map (fun x -> PInac x) l - -exception Conflict - -let rec pmatch p c = - match p, c with - | PRel i, t -> [i, t] - | PCstr (c, pl), PCstr (c', pl') when c = c' -> pmatches pl pl' - | PInac _, _ -> [] - | _, PInac _ -> [] - | _, _ -> raise Conflict - -and pmatches pl l = - match pl, l with - | [], [] -> [] - | hd :: tl, hd' :: tl' -> - pmatch hd hd' @ pmatches tl tl' - | _ -> raise Conflict - -let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None - -let rec pinclude p c = - match p, c with - | PRel i, t -> true - | PCstr (c, pl), PCstr (c', pl') when c = c' -> pincludes pl pl' - | PInac _, _ -> true - | _, PInac _ -> true - | _, _ -> false - -and pincludes pl l = - match pl, l with - | [], [] -> true - | hd :: tl, hd' :: tl' -> - pinclude hd hd' && pincludes tl tl' - | _ -> false - -let pattern_includes pl l = pincludes pl l - -(** Specialize by a substitution. *) - -let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s) - -let subst_rel_subst k s c = - let rec aux depth c = - match kind_of_term c with - | Rel n -> - let k = n - depth in - if k >= 0 then - try lift depth (snd (assoc k s)) - with Not_found -> c - else c - | _ -> map_constr_with_binders succ aux depth c - in aux k c - -let subst_context s ctx = - let (_, ctx') = fold_right - (fun (id, b, t) (k, ctx') -> - (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx')) - ctx (0, []) - in ctx' - -let subst_rel_context k cstr ctx = - let (_, ctx') = fold_right - (fun (id, b, t) (k, ctx') -> - (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) - ctx (k, []) - in ctx' - -let rec lift_pat n k p = - match p with - | PRel i -> - if i >= k then PRel (i + n) - else p - | PCstr(c, pl) -> PCstr (c, lift_pats n k pl) - | PInac r -> PInac (liftn n k r) - -and lift_pats n k = map (lift_pat n k) - -let rec subst_pat env k t p = - match p with - | PRel i -> - if i = k then t - else if i > k then PRel (pred i) - else p - | PCstr(c, pl) -> - PCstr (c, subst_pats env k t pl) - | PInac r -> PInac (substnl [constr_of_pat ~inacc:false env t] (pred k) r) - -and subst_pats env k t = map (subst_pat env k t) - -let rec specialize s p = - match p with - | PRel i -> - if mem_assoc i s then - let b, t = assoc i s in - if b then PInac t - else PRel (destRel t) - else p - | PCstr(c, pl) -> - PCstr (c, specialize_pats s pl) - | PInac r -> PInac (specialize_constr s r) - -and specialize_constr s c = subst_rel_subst 0 s c -and specialize_pats s = map (specialize s) - -let specialize_patterns = function - | [] -> fun p -> p - | s -> specialize_pats s - -let specialize_rel_context s ctx = - snd (fold_right (fun (n, b, t) (k, ctx) -> - (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx)) - ctx (0, [])) - -let lift_contextn n k sign = - let rec liftrec k = function - | (na,c,t)::sign -> - (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) - | [] -> [] - in - liftrec (rel_context_length sign + k) sign - -type program = - signature * clause list - -and signature = identifier * rel_context * constr - -and clause = lhs * (constr, int) rhs - -and lhs = rel_context * identifier * pat list - -and ('a, 'b) rhs = - | Program of 'a - | Empty of 'b - -type splitting = - | Compute of clause - | Split of lhs * int * inductive_family * - unification_result array * splitting option array - -and unification_result = - rel_context * int * constr * pat * substitution option - -and substitution = (int * (bool * constr)) list - -type problem = identifier * lhs - -let rels_of_tele tele = rel_list 0 (List.length tele) - -let patvars_of_tele tele = map (fun c -> PRel (destRel c)) (rels_of_tele tele) - -let split_solves split prob = - match split with - | Compute (lhs, rhs) -> lhs = prob - | Split (lhs, id, indf, us, ls) -> lhs = prob - -let ids_of_constr c = - let rec aux vars c = - match kind_of_term c with - | Var id -> Idset.add id vars - | _ -> fold_constr aux vars c - in aux Idset.empty c - -let ids_of_constrs = - fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty - -let idset_of_list = - fold_left (fun s x -> Idset.add x s) Idset.empty - -let intset_of_list = - fold_left (fun s x -> Intset.add x s) Intset.empty - -let solves split (delta, id, pats as prob) = - split_solves split prob && - Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta))) - -let check_judgment ctx c t = - ignore(Typing.check (push_rel_context ctx (Global.env ())) Evd.empty c t); true - -let check_context env ctx = - fold_right - (fun (_, _, t as decl) env -> - ignore(Typing.sort_of env Evd.empty t); push_rel decl env) - ctx env - -let split_context n c = - let after, before = list_chop n c in - match before with - | hd :: tl -> after, hd, tl - | [] -> raise (Invalid_argument "split_context") - -let split_tele n (ctx : rel_context) = - let rec aux after n l = - match n, l with - | 0, decl :: before -> before, decl, List.rev after - | n, decl :: before -> aux (decl :: after) (pred n) before - | _ -> raise (Invalid_argument "split_tele") - in aux [] n ctx - -let rec add_var_subst env subst n c = - if mem_assoc n subst then - let t = assoc n subst in - if eq_constr t c then subst - else unify env subst t c - else - let rel = mkRel n in - if rel = c then subst - else if dependent rel c then raise Conflict - else (n, c) :: subst - -and unify env subst x y = - match kind_of_term x, kind_of_term y with - | Rel n, _ -> add_var_subst env subst n y - | _, Rel n -> add_var_subst env subst n x - | App (c, l), App (c', l') when eq_constr c c' -> - unify_constrs env subst (Array.to_list l) (Array.to_list l') - | _, _ -> if eq_constr x y then subst else raise Conflict - -and unify_constrs (env : env) subst l l' = - if List.length l = List.length l' then - fold_left2 (unify env) subst l l' - else raise Conflict - -let fold_rel_context_with_binders f ctx init = - snd (List.fold_right (fun decl (depth, acc) -> - (succ depth, f depth decl acc)) ctx (0, init)) - -let dependent_rel_context (ctx : rel_context) k = - fold_rel_context_with_binders - (fun depth (n,b,t) acc -> - let r = mkRel (depth + k) in - acc || dependent r t || - (match b with - | Some b -> dependent r b - | None -> false)) - ctx false - -let liftn_between n k p c = - let rec aux depth c = match kind_of_term c with - | Rel i -> - if i <= depth then c - else if i-depth > p then c - else mkRel (i - n) - | _ -> map_constr_with_binders succ aux depth c - in aux k c - -let liftn_rel_context n k sign = - let rec liftrec k = function - | (na,c,t)::sign -> - (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) - | [] -> [] - in - liftrec (k + rel_context_length sign) sign - -let substnl_rel_context n l = - map_rel_context_with_binders (fun k -> substnl l (n+k-1)) - -let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list) = - let _, s, ctx' = - fold_left (fun (k, s, ctx') (n, b, t as decl) -> - match b with - | None -> (succ k, mkRel k :: s, ctx' @ [decl]) - | Some t -> (k, lift (pred k) t :: map (substnl [t] (pred k)) s, subst_rel_context 0 t ctx')) - (1, [], []) ctx - in - let s = rev s in - let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in - s', ctx' - -(* Compute the transitive closure of the dependency relation for a term in a context *) - -let rec dependencies_of_rel ctx k = - let (n,b,t) = nth ctx (pred k) in - let b = Option.map (lift k) b and t = lift k t in - let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in - Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t)) - -and dependencies_of_term ctx t = - let rels = free_rels t in - Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty - -let subst_telescope k cstr ctx = - let (_, ctx') = fold_left - (fun (k, ctx') (id, b, t) -> - (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) - (k, []) ctx - in rev ctx' - -let lift_telescope n k sign = - let rec liftrec k = function - | (na,c,t)::sign -> - (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign) - | [] -> [] - in liftrec k sign - -type ('a,'b) either = Inl of 'a | Inr of 'b - -let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list = - let rels = dependencies_of_term ctx t in - let len = length ctx in - let nbdeps = Intset.cardinal rels in - let lifting = len - nbdeps in (* Number of variables not linked to t *) - let rec aux k n acc m rest s = function - | decl :: ctx' -> - if Intset.mem k rels then - let rest' = subst_telescope 0 (mkRel (nbdeps + lifting - pred m)) rest in - aux (succ k) (succ n) (decl :: acc) m rest' ((k, Inl n) :: s) ctx' - else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx' - | [] -> rev acc, rev rest, s - in aux 1 1 [] 1 [] [] ctx - -let merge_subst (ctx', rest, s) = - let lenrest = length rest in - map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s - -(* let simplify_subst s = *) -(* fold_left (fun s (k, t) -> *) -(* match kind_of_term t with *) -(* | Rel n when n = k -> s *) -(* | _ -> (k, t) :: s) *) -(* [] s *) - -let compose_subst s' s = - map (fun (k, (b, t)) -> (k, (b, specialize_constr s' t))) s - -let substitute_in_ctx n c ctx = - let rec aux k after = function - | [] -> [] - | (name, b, t as decl) :: before -> - if k = n then rev after @ (name, Some c, t) :: before - else aux (succ k) (decl :: after) before - in aux 1 [] ctx - -let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) = - match cursubst with - | [] -> ctx, substacc - | (k, (b, t)) :: rest -> - if t = mkRel k then reduce_subst ctx substacc rest - else if noccur_between 1 k t then - (* The term to substitute refers only to previous variables. *) - let t' = lift (-k) t in - let ctx' = substitute_in_ctx k t' ctx in - reduce_subst ctx' substacc rest - else (* The term refers to variables declared after [k], so we have - to move these dependencies before [k]. *) - let (minctx, ctxrest, subst as str) = strengthen ctx t in - match assoc k subst with - | Inl _ -> error "Occurs check in substituted_context" - | Inr k' -> - let s = merge_subst str in - let ctx' = ctxrest @ minctx in - let rest' = - let substsubst (k', (b, t')) = - match kind_of_term (snd (assoc k' s)) with - | Rel k'' -> (k'', (b, specialize_constr s t')) - | _ -> error "Non-variable substituted for variable by strenghtening" - in map substsubst ((k, (b, t)) :: rest) - in - reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *) - - -let substituted_context (subst : (int * constr) list) (ctx : rel_context) = - let _, subst = - fold_left (fun (k, s) _ -> - try let t = assoc k subst in - (succ k, (k, (true, t)) :: s) - with Not_found -> - (succ k, ((k, (false, mkRel k)) :: s))) - (1, []) ctx - in - let ctx', subst' = reduce_subst ctx subst subst in - reduce_rel_context ctx' subst' - -let unify_type before ty = - try - let envb = push_rel_context before (Global.env()) in - let IndType (indf, args) = find_rectype envb Evd.empty ty in - let ind, params = dest_ind_family indf in - let vs = map (Reduction.whd_betadeltaiota envb) args in - let cstrs = Inductiveops.arities_of_constructors envb ind in - let cstrs = - Array.mapi (fun i ty -> - let ty = prod_applist ty params in - let ctx, ty = decompose_prod_assum ty in - let ctx, ids = - let ids = ids_of_rel_context ctx in - fold_right (fun (n, b, t as decl) (acc, ids) -> - match n with Name _ -> (decl :: acc), ids - | Anonymous -> let id = next_name_away Anonymous ids in - ((Name id, b, t) :: acc), (id :: ids)) - ctx ([], ids) - in - let env' = push_rel_context ctx (Global.env ()) in - let IndType (indf, args) = find_rectype env' Evd.empty ty in - let ind, params = dest_ind_family indf in - let constr = applist (mkConstruct (ind, succ i), params @ rels_of_tele ctx) in - let constrpat = PCstr ((ind, succ i), inaccs_of_constrs params @ patvars_of_tele ctx) in - env', ctx, constr, constrpat, (* params @ *)args) - cstrs - in - let res = - Array.map (fun (env', ctxc, c, cpat, us) -> - let _beforelen = length before and ctxclen = length ctxc in - let fullctx = ctxc @ before in - try - let fullenv = push_rel_context fullctx (Global.env ()) in - let vs' = map (lift ctxclen) vs in - let subst = unify_constrs fullenv [] vs' us in - let subst', ctx' = substituted_context subst fullctx in - (ctx', ctxclen, c, cpat, Some subst') - with Conflict -> - (fullctx, ctxclen, c, cpat, None)) cstrs - in Some (res, indf) - with Not_found -> (* not an inductive type *) - None - -let rec id_of_rel n l = - match n, l with - | 0, (Name id, _, _) :: tl -> id - | n, _ :: tl -> id_of_rel (pred n) tl - | _, _ -> raise (Invalid_argument "id_of_rel") - -let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = - constrs_of_pats ~inacc (push_rel_context ctx env) pats - -let rec valid_splitting (f, delta, t, pats) tree = - split_solves tree (delta, f, pats) && - valid_splitting_tree (f, delta, t) tree - -and valid_splitting_tree (f, delta, t) = function - | Compute (lhs, Program rhs) -> - let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in - ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true - - | Compute ((ctx, id, lhs), Empty split) -> - let before, (x, _, ty), after = split_context split ctx in - let unify = - match unify_type before ty with - | Some (unify, _) -> unify - | None -> assert false - in - array_for_all (fun (_, _, _, _, x) -> x = None) unify - - | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> - let before, (id, _, ty), after = split_tele (pred rel) ctx in - let unify, indf' = Option.get (unify_type before ty) in - assert(indf = indf'); - if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false - else - let ok, splits = - Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> - match subst with - | None -> acc - | Some subst -> -(* let env' = push_rel_context ctx' (Global.env ()) in *) -(* let ctx_correct = *) -(* ignore(check_context env' (subst_context subst ctxc)); *) -(* ignore(check_context env' (subst_context subst before)); *) -(* true *) -(* in *) - let newdelta = - subst_context subst (subst_rel_context 0 cstr - (lift_contextn ctxlen 0 after)) @ before in - let liftpats = lift_pats ctxlen rel lhs in - let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in - (ok, (f, newdelta, newpats) :: splits)) - (true, []) unify - in - let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta - (constrs_of_pats ~inacc:false (Global.env ()) lhs) - in - let t' = replace_vars subst t in - ok && for_all - (fun (f, delta', pats') -> - array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits - -let valid_tree (f, delta, t) tree = - valid_splitting (f, delta, t, patvars_of_tele delta) tree - -let is_constructor c = - match kind_of_term (fst (decompose_app c)) with - | Construct _ -> true - | _ -> false - -let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) = - let rec find_split_pat curpat patc = - match patc with - | PRel _ -> None - | PCstr (f, args) -> - (match curpat with - | PCstr (f', args') when f = f' -> (* Already split at this level, continue *) - find_split_pats args' args - | PRel i -> (* Split on i *) Some i - | PInac c when isRel c -> Some (destRel c) - | _ -> None) - | PInac _ -> None - - and find_split_pats curpats patcs = - assert(List.length curpats = List.length patcs); - fold_left2 (fun acc -> - match acc with - | None -> find_split_pat | _ -> fun _ _ -> acc) - None curpats patcs - in find_split_pats curpats patcs - -open Pp -open Termops - -let pr_constr_pat env c = - let pr = print_constr_env env c in - match kind_of_term c with - | App _ -> str "(" ++ pr ++ str ")" - | _ -> pr - -let pr_pat env c = - try - let patc = constr_of_pat env c in - try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception" - with _ -> str"constr_of_pat raised an exception" - -let pr_context env c = - let pr_decl (id,b,_) = - let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in - let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in - idstr ++ bstr - in - prlist_with_sep pr_spc pr_decl (List.rev c) -(* Printer.pr_rel_context env c *) - -let pr_lhs env (delta, f, patcs) = - let env = push_rel_context delta env in - let ctx = pr_context env delta in - (if delta = [] then ctx else str "[" ++ ctx ++ str "]" ++ spc ()) - ++ pr_id f ++ spc () ++ prlist_with_sep spc (pr_pat env) patcs - -let pr_rhs env = function - | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var) - | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs - -let pr_clause env (lhs, rhs) = - pr_lhs env lhs ++ - (let env' = push_rel_context (pi1 lhs) env in - pr_rhs env' rhs) - -(* let pr_splitting env = function *) -(* | Compute cl -> str "Compute " ++ pr_clause env cl *) -(* | Split (lhs, n, indf, results, splits) -> *) - -(* let pr_unification_result (ctx, n, c, pat, subst) = *) - -(* unification_result array * splitting option array *) - -let pr_clauses env = - prlist_with_sep fnl (pr_clause env) - -let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = - pattern_includes patcs patcs' - -let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = - pattern_matches patcs patcs' - -let rec split_on env var (delta, f, curpats as lhs) clauses = - let before, (id, _, ty), after = split_tele (pred var) delta in - let unify, indf = - match unify_type before ty with - | Some r -> r - | None -> assert false (* We decided... so it better be inductive *) - in - let clauses = ref clauses in - let splits = - Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) -> - match s with - | None -> None - | Some s -> - (* ctx' |- s cstr, s cstrpat *) - let newdelta = - subst_context s (subst_rel_context 0 cstr - (lift_contextn ctxlen 1 after)) @ ctx' in - let liftpats = - (* delta |- curpats -> before; ctxc; id; after |- liftpats *) - lift_pats ctxlen (succ var) curpats - in - let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *) - lift_pat (pred var) 1 cstrpat - in - let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *) - subst_pats env var liftpat liftpats - in - let lifts = (* before; ctxc |- s : newdelta -> - before; ctxc; after |- lifts : newdelta ; after *) - map (fun (k,(b,x)) -> (pred var + k, (b, lift (pred var) x))) s - in - let newpats = specialize_patterns lifts substpat in - let newlhs = (newdelta, f, newpats) in - let matching, rest = - fold_right (fun (lhs, rhs as clause) (matching, rest) -> - if lhs_includes newlhs lhs then - (clause :: matching, rest) - else (matching, clause :: rest)) - !clauses ([], []) - in - clauses := rest; - if matching = [] then ( - (* Try finding a splittable variable *) - let (id, _) = - fold_right (fun (id, _, ty as decl) (accid, ctx) -> - match accid with - | Some _ -> (accid, ctx) - | None -> - match unify_type ctx ty with - | Some (unify, indf) -> - if array_for_all (fun (_, _, _, _, x) -> x = None) unify then - (Some id, ctx) - else (None, decl :: ctx) - | None -> (None, decl :: ctx)) - newdelta (None, []) - in - match id with - | None -> - errorlabstrm "deppat" - (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++ - pr_lhs env newlhs) - | Some id -> - Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta)))) - ) else ( - let splitting = make_split_aux env newlhs matching in - Some splitting)) - unify - in -(* if !clauses <> [] then *) -(* errorlabstrm "deppat" *) -(* (str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *) - Split (lhs, var, indf, unify, splits) - -and make_split_aux env lhs clauses = - let split = - fold_left (fun acc (lhs', rhs) -> - match acc with - | None -> find_split lhs lhs' - | _ -> acc) None clauses - in - match split with - | Some var -> split_on env var lhs clauses - | None -> - (match clauses with - | [] -> error "No clauses left" - | [(lhs', rhs)] -> - (* No need to split anymore, fix the environments so that they are correctly aligned. *) - (match lhs_matches lhs' lhs with - | Some s -> - let s = map (fun (x, p) -> x, (true, constr_of_pat ~inacc:false env p)) s in - let rhs' = match rhs with - | Program c -> Program (specialize_constr s c) - | Empty i -> Empty (destRel (snd (assoc i s))) - in Compute ((pi1 lhs, pi2 lhs, specialize_patterns s (pi3 lhs')), rhs') - | None -> anomaly "Non-matching clauses at a leaf of the splitting tree") - | _ -> - errorlabstrm "make_split_aux" - (str "Overlapping clauses:" ++ fnl () ++ pr_clauses env clauses)) - -let make_split env (f, delta, t) clauses = - make_split_aux env (delta, f, patvars_of_tele delta) clauses - -open Evd -open Evarutil - -let lift_substitution n s = map (fun (k, x) -> (k + n, x)) s -let map_substitution s t = map (subst_rel_subst 0 s) t - -let term_of_tree status isevar env (i, delta, ty) ann tree = -(* let envrec = match ann with *) -(* | None -> [] *) -(* | Some (loc, i) -> *) -(* let (n, t) = lookup_rel_id i delta in *) -(* let t' = lift n t in *) - - -(* in *) - let rec aux = function - | Compute ((ctx, _, pats as lhs), Program rhs) -> - let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in - mkCast(body, DEFAULTcast, typ), typ - - | Compute ((ctx, _, pats as lhs), Empty split) -> - let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let split = (Name (id_of_string "split"), - Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))), - Lazy.force Class_tactics.coq_nat) - in - let ty' = it_mkProd_or_LetIn ty' ctx in - let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in - let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in - term, ty' - - | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> - let before, decl, after = split_tele (pred rel) ctx in - let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let branches = - array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> - match split with - | Some s -> aux s - | None -> - (* dead code, inversion will find a proof of False by splitting on the rel'th hyp *) - Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat) - unif sp - in - let branches_ctx = - Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt)) - branches - in - let n, branches_lets = - Array.fold_left (fun (n, lets) (id, b, t) -> - (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets)) - (0, []) branches_ctx - in - let liftctx = lift_contextn (Array.length branches) 0 ctx in - let case = - let ty = it_mkProd_or_LetIn ty' liftctx in - let ty = it_mkLambda_or_LetIn ty branches_lets in - let nbbranches = (Name (id_of_string "branches"), - Some (Class_tactics.coq_nat_of_int (length branches_lets)), - Lazy.force Class_tactics.coq_nat) - in - let nbdiscr = (Name (id_of_string "target"), - Some (Class_tactics.coq_nat_of_int (length before)), - Lazy.force Class_tactics.coq_nat) - in - let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in - let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in - term - in - let casetyp = it_mkProd_or_LetIn ty' ctx in - mkCast(case, DEFAULTcast, casetyp), casetyp - - in aux tree - -open Topconstr -open Constrintern -open Decl_kinds - -type equation = constr_expr * (constr_expr, identifier located) rhs - -let locate_reference qid = - match Nametab.extended_locate qid with - | TrueGlobal ref -> true - | SyntacticDef kn -> true - -let is_global id = - try - locate_reference (make_short_qualid id) - with Not_found -> - false - -let is_freevar ids env x = - try - if Idset.mem x ids then false - else - try ignore(Environ.lookup_named x env) ; false - with _ -> not (is_global x) - with _ -> true - -let ids_of_patc c ?(bound=Idset.empty) l = - let found id bdvars l = - if not (is_freevar bdvars (Global.env ()) (snd id)) then l - else if List.exists (fun (_, id') -> id' = snd id) l then l - else id :: l - in - let rec aux bdvars l c = match c with - | CRef (Ident lid) -> found lid bdvars l - | CNotation (_, "{ _ : _ | _ }", ((CRef (Ident (_, id))) :: _, _)) when not (Idset.mem id bdvars) -> - fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c - | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c - in aux bound l c - -let interp_pats i isevar env impls pat sign recu = - let bound = Idset.singleton i in - let vars = ids_of_patc pat ~bound [] in - let varsctx, env' = - fold_right (fun (loc, id) (ctx, env) -> - let decl = - let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in - (Name id, None, ty) - in - decl::ctx, push_rel decl env) - vars ([], env) - in - let pats = - let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in - let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in - match kind_of_term patt with - | App (m, args) -> - if not (eq_constr m (mkRel (succ (length varsctx)))) then - user_err_loc (constr_loc pat, "interp_pats", - str "Expecting a pattern for " ++ pr_id i) - else Array.to_list args - | _ -> user_err_loc (constr_loc pat, "interp_pats", - str "Error parsing pattern: unnexpected left-hand side") - in - isevar := nf_evar_defs !isevar; - (nf_rel_context_evar (Evd.evars_of !isevar) varsctx, - nf_env_evar (Evd.evars_of !isevar) env', - rev_map (nf_evar (Evd.evars_of !isevar)) pats) - -let interp_eqn i isevar env impls sign arity recu (pats, rhs) = - let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in - let rhs' = match rhs with - | Program p -> - let ty = nf_isevar !isevar (substl patcs arity) in - Program (interp_casted_constr_evars isevar env' ~impls p ty) - | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx)) - in ((ctx, i, pats_of_constrs (rev patcs)), rhs') - -open Entries - -open Tacmach -open Tacexpr -open Tactics -open Tacticals - -let contrib_tactics_path = - make_dirpath (List.map id_of_string ["Equality";"Program";"Coq"]) - -let tactics_tac s = - make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s) - -let equations_tac = lazy - (Tacinterp.eval_tactic - (TacArg(TacCall(dummy_loc, - ArgArg(dummy_loc, tactics_tac "equations"), [])))) - -let define_by_eqs with_comp i (l,ann) t nt eqs = - let env = Global.env () in - let isevar = ref (create_evar_defs Evd.empty) in - let (env', sign), impls = interp_context_evars isevar env l in - let arity = interp_type_evars isevar env' t in - let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in - let arity = nf_evar (Evd.evars_of !isevar) arity in - let arity = - if with_comp then - let compid = add_suffix i "_comp" in - let ce = - { const_entry_body = it_mkLambda_or_LetIn arity sign; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = false} - in - let c = - Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition) - in mkApp (mkConst c, rel_vect 0 (length sign)) - else arity - in - let env = Global.env () in - let ty = it_mkProd_or_LetIn arity sign in - let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in - let fixdecls = [(Name i, None, ty)] in - let fixenv = push_rel_context fixdecls env in - let equations = - States.with_heavy_rollback (fun () -> - Option.iter (Command.declare_interning_data data) nt; - map (interp_eqn i isevar fixenv data sign arity None) eqs) () - in - let sign = nf_rel_context_evar (Evd.evars_of !isevar) sign in - let arity = nf_evar (Evd.evars_of !isevar) arity in - let prob = (i, sign, arity) in - let fixenv = nf_env_evar (Evd.evars_of !isevar) fixenv in - let fixdecls = nf_rel_context_evar (Evd.evars_of !isevar) fixdecls in - (* let ce = check_evars fixenv Evd.empty !isevar in *) - (* List.iter (function (_, _, Program rhs) -> ce rhs | _ -> ()) equations; *) - let is_recursive, env' = - let occur_eqn ((ctx, _, _), rhs) = - match rhs with - | Program c -> dependent (mkRel (succ (length ctx))) c - | _ -> false - in if exists occur_eqn equations then true, fixenv else false, env - in - let split = make_split env' prob equations in - (* if valid_tree prob split then *) - let status = (* if is_recursive then Expand else *) Define false in - let t, ty = term_of_tree status isevar env' prob ann split in - let undef = undefined_evars !isevar in - let t, ty = if is_recursive then - (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls) - else t, ty - in - let obls, t', ty' = - Eterm.eterm_obligations env i !isevar (Evd.evars_of undef) 0 ~status t ty - in - if is_recursive then - ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] - ~tactic:(Lazy.force equations_tac) - (Command.IsFixpoint [None, CStructRec])) - else - ignore(Subtac_obligations.add_definition - ~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls) - -module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic - -module DeppatGram = -struct - let gec s = Gram.Entry.create ("Deppat."^s) - - let deppat_equations : equation list Gram.Entry.e = gec "deppat_equations" - - let binders_let2 : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e = gec "binders_let2" - -(* let where_decl : decl_notation Gram.Entry.e = gec "where_decl" *) - -end - -open Rawterm -open DeppatGram -open Util -open Pcoq -open Prim -open Constr -open G_vernac - -GEXTEND Gram - GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2; - - deppat_equations: - [ [ l = LIST1 equation SEP ";" -> l ] ] - ; - - binders_let2: - [ [ l = binders_let_fixannot -> l ] ] - ; - - equation: - [ [ c = Constr.lconstr; r=rhs -> (c, r) ] ] - ; - - rhs: - [ [ ":=!"; id = identref -> Empty id - |":="; c = Constr.lconstr -> Program c - ] ] - ; - - END - -type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type - -let (wit_deppat_equations : Genarg.tlevel deppat_equations_argtype), - (globwit_deppat_equations : Genarg.glevel deppat_equations_argtype), - (rawwit_deppat_equations : Genarg.rlevel deppat_equations_argtype) = - Genarg.create_arg "deppat_equations" - -type 'a binders_let2_argtype = (local_binder list * (identifier located option * recursion_order_expr), 'a) Genarg.abstract_argument_type - -let (wit_binders_let2 : Genarg.tlevel binders_let2_argtype), - (globwit_binders_let2 : Genarg.glevel binders_let2_argtype), - (rawwit_binders_let2 : Genarg.rlevel binders_let2_argtype) = - Genarg.create_arg "binders_let2" - -type 'a decl_notation_argtype = (Vernacexpr.decl_notation, 'a) Genarg.abstract_argument_type - -let (wit_decl_notation : Genarg.tlevel decl_notation_argtype), - (globwit_decl_notation : Genarg.glevel decl_notation_argtype), - (rawwit_decl_notation : Genarg.rlevel decl_notation_argtype) = - Genarg.create_arg "decl_notation" - -let equations wc i l t nt eqs = - try define_by_eqs wc i l t nt eqs - with e -> msg (Cerrors.explain_exn e) - -VERNAC COMMAND EXTEND Define_equations -| [ "Equations" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) - decl_notation(nt) ] -> - [ equations true i l t nt eqs ] - END - -VERNAC COMMAND EXTEND Define_equations2 -| [ "Equations_nocomp" ident(i) binders_let2(l) ":" lconstr(t) ":=" deppat_equations(eqs) - decl_notation(nt) ] -> - [ equations false i l t nt eqs ] -END - -let rec int_of_coq_nat c = - match kind_of_term c with - | App (f, [| arg |]) -> succ (int_of_coq_nat arg) - | _ -> 0 - -let solve_equations_goal destruct_tac tac gl = - let concl = pf_concl gl in - let targetn, branchesn, targ, brs, b = - match kind_of_term concl with - | LetIn (Name target, targ, _, b) -> - (match kind_of_term b with - | LetIn (Name branches, brs, _, b) -> - target, branches, int_of_coq_nat targ, int_of_coq_nat brs, b - | _ -> error "Unnexpected goal") - | _ -> error "Unnexpected goal" - in - let branches, b = - let rec aux n c = - if n = 0 then [], c - else match kind_of_term c with - | LetIn (Name id, br, brt, b) -> - let rest, b = aux (pred n) b in - (id, br, brt) :: rest, b - | _ -> error "Unnexpected goal" - in aux brs b - in - let ids = targetn :: branchesn :: map pi1 branches in - let cleantac = tclTHEN (intros_using ids) (thin ids) in - let dotac = tclDO (succ targ) intro in - let subtacs = - tclTHENS destruct_tac - (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches) - in tclTHENLIST [cleantac ; dotac ; subtacs] gl - -TACTIC EXTEND solve_equations - [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ] - END - -let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq -let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl) - -let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") -let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") - -let specialize_hyp id gl = - let env = pf_env gl in - let ty = pf_get_hyp_typ gl id in - let evars = ref (create_evar_defs (project gl)) in - let rec aux in_eqs acc ty = - match kind_of_term ty with - | Prod (_, t, b) -> - (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> - let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in - let p = mkApp (Lazy.force coq_eq_refl, [| eqty; x |]) in - if e_conv env evars pt t then - aux true (mkApp (acc, [| p |])) (subst1 p b) - else error "Unconvertible members of an homogeneous equality" - | App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) -> - let pt = mkApp (Lazy.force coq_heq, [| eqty; x; eqty; x |]) in - let p = mkApp (Lazy.force coq_heq_refl, [| eqty; x |]) in - if e_conv env evars pt t then - aux true (mkApp (acc, [| p |])) (subst1 p b) - else error "Unconvertible members of an heterogeneous equality" - | _ -> - if in_eqs then acc, in_eqs, ty - else - let e = e_new_evar evars env t in - aux false (mkApp (acc, [| e |])) (subst1 e b)) - | t -> acc, in_eqs, ty - in - try - let acc, worked, ty = aux false (mkVar id) ty in - let ty = Evarutil.nf_isevar !evars ty in - if worked then - tclTHENFIRST - (fun g -> Tacmach.internal_cut true id ty g) - (exact_no_check (Evarutil.nf_isevar !evars acc)) gl - else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl - with e -> tclFAIL 0 (Cerrors.explain_exn e) gl - -TACTIC EXTEND specialize_hyp -[ "specialize_hypothesis" constr(c) ] -> [ - match kind_of_term c with - | Var id -> specialize_hyp id - | _ -> tclFAIL 0 (str "Not an hypothesis") ] -END diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml deleted file mode 100644 index 00a69bba..00000000 --- a/contrib/subtac/eterm.ml +++ /dev/null @@ -1,221 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -(** - - Get types of existentials ; - - Flatten dependency tree (prefix order) ; - - Replace existentials by De Bruijn indices in term, applied to the right arguments ; - - Apply term prefixed by quantification on "existentials". -*) - -open Term -open Sign -open Names -open Evd -open List -open Pp -open Util -open Subtac_utils -open Proof_type - -let trace s = - if !Flags.debug then (msgnl s; msgerr s) - else () - -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -type oblinfo = - { ev_name: int * identifier; - ev_hyps: named_context; - ev_status: obligation_definition_status; - ev_chop: int option; - ev_loc: Util.loc; - ev_typ: types; - ev_tac: Tacexpr.raw_tactic_expr option; - ev_deps: Intset.t } - -(** Substitute evar references in t using De Bruijn indices, - where n binders were passed through. *) - -let subst_evar_constr evs n t = - let seen = ref Intset.empty in - let transparent = ref Idset.empty in - let evar_info id = List.assoc id evs in - let rec substrec (depth, fixrels) c = match kind_of_term c with - | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") - in - seen := Intset.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = list_chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = - match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | ((_, Some _, _) :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then - transparent := Idset.add idstr !transparent; - mkApp (mkVar idstr, Array.of_list args) - | Fix _ -> - map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c - | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - t', !seen, !transparent - - -(** Substitute variable references in t using De Bruijn indices, - where n binders were passed through. *) -let subst_vars acc n t = - let var_index id = Util.list_index id acc in - let rec substrec depth c = match kind_of_term c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> map_constr_with_binders succ substrec depth c - in - substrec 0 t - -(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. - Changes evars and hypothesis references to variable references. - A little optimization: don't include unnecessary let-ins and their dependencies. -*) -let etype_of_evar evs hyps concl = - let rec aux acc n = function - (id, copt, t) :: tl -> - let t', s, trans = subst_evar_constr evs n t in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (id :: acc) (succ n) tl in - let s' = Intset.union s s' in - let trans' = Idset.union trans trans' in - (match copt with - Some c -> -(* if noccurn 1 rest then lift (-1) rest, s', trans' *) -(* else *) - let c', s'', trans'' = subst_evar_constr evs n c in - let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (id, Some c', t'') rest, - Intset.union s'' s', - Idset.union trans'' trans' - | None -> - mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') - | [] -> - let t', s, trans = subst_evar_constr evs n concl in - subst_vars acc 0 t', s, trans - in aux [] 0 (rev hyps) - - -open Tacticals - -let trunc_named_context n ctx = - let len = List.length ctx in - list_firstn (len - n) ctx - -let rec chop_product n t = - if n = 0 then Some t - else - match kind_of_term t with - | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None - | _ -> None - -let evar_dependencies evm ev = - let one_step deps = - Intset.fold (fun ev s -> - let evi = Evd.find evm ev in - Intset.union (Evarutil.evars_of_evar_info evi) s) - deps deps - in - let rec aux deps = - let deps' = one_step deps in - if Intset.equal deps deps' then deps - else aux deps' - in aux (Intset.singleton ev) - -let sort_dependencies evl = - List.sort (fun (_, _, deps) (_, _, deps') -> - if Intset.subset deps deps' then (* deps' depends on deps *) -1 - else if Intset.subset deps' deps then 1 - else Intset.compare deps deps') - evl - -let eterm_obligations env name isevars evm fs ?status t ty = - (* 'Serialize' the evars *) - let nc = Environ.named_context env in - let nc_len = Sign.named_context_length nc in - let evl = List.rev (to_list evm) in - let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in - let sevl = sort_dependencies evl in - let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = - let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; - (id, (!i, id_of_string - (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl - in - let evts = - (* Remove existential variables in types and build the corresponding products *) - fold_right - (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = evar_source id isevars in - let status = match k with QuestionMark o -> Some o | _ -> status in - let status, chop = match status with - | Some (Define true as stat) -> - if chop <> fs then Define false, None - else stat, Some chop - | Some s -> s, None - | None -> Define true, None - in - let tac = match ev.evar_extra with - | Some t -> - if Dyn.tag t = "tactic" then - Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t)) - else None - | None -> None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = status; ev_chop = chop; - ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } - in (id, info) :: l) - evn [] - in - let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 t - in - let ty, _, _ = subst_evar_constr evts 0 ty in - let evars = - List.map (fun (_, info) -> - let { ev_name = (_, name); ev_status = status; - ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info - in - let status = match status with - | Define true when Idset.mem name transparent -> Define false - | _ -> status - in name, typ, loc, status, deps, tac) evts - in Array.of_list (List.rev evars), t', ty - -let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n - -let etermtac (evm, t) = assert(false) (*eterm evm t None *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli deleted file mode 100644 index 19e8ffe8..00000000 --- a/contrib/subtac/eterm.mli +++ /dev/null @@ -1,32 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: eterm.mli 11576 2008-11-10 19:13:15Z msozeau $ i*) -open Environ -open Tacmach -open Term -open Evd -open Names -open Util -open Tacinterp - -val mkMetas : int -> constr list - -val evar_dependencies : evar_map -> int -> Intset.t -val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list - -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> - ?status:obligation_definition_status -> constr -> types -> - (identifier * types * loc * obligation_definition_status * Intset.t * - Tacexpr.raw_tactic_expr option) array * constr * types - (* Obl. name, type as product, location of the original evar, associated tactic, - status and dependencies as indexes into the array *) - -val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_eterm.ml4 b/contrib/subtac/g_eterm.ml4 deleted file mode 100644 index d9dd42cd..00000000 --- a/contrib/subtac/g_eterm.ml4 +++ /dev/null @@ -1,27 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(**************************************************************************) -(* *) -(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) -(* *) -(* Pierre Crégut (CNET, Lannion, France) *) -(* *) -(**************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_eterm.ml4 8654 2006-03-22 15:36:58Z msozeau $ *) - -open Eterm - -TACTIC EXTEND eterm - [ "eterm" ] -> [ - (fun gl -> - let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in - Eterm.etermtac (evm, t) gl) ] -END diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 deleted file mode 100644 index 7194d435..00000000 --- a/contrib/subtac/g_subtac.ml4 +++ /dev/null @@ -1,156 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) - - -(* - Syntax for the subtac terms and types. - Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) - -(* $Id: g_subtac.ml4 11576 2008-11-10 19:13:15Z msozeau $ *) - - -open Flags -open Util -open Names -open Nameops -open Vernacentries -open Reduction -open Term -open Libnames -open Topconstr - -(* We define new entries for programs, with the use of this module - * Subtac. These entries are named Subtac.<foo> - *) - -module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ -module Tactic = Pcoq.Tactic - -module SubtacGram = -struct - let gec s = Gram.Entry.create ("Subtac."^s) - (* types *) - let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc" - - let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt" -end - -open Rawterm -open SubtacGram -open Util -open Pcoq -open Prim -open Constr -let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) - -GEXTEND Gram - GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt; - - subtac_gallina_loc: - [ [ g = Vernac.gallina -> loc, g - | g = Vernac.gallina_ext -> loc, g ] ] - ; - - subtac_nameopt: - [ [ "ofb"; id=Prim.ident -> Some (id) - | -> None ] ] - ; - - Constr.binder_let: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [LocalRawAssum ([id], default_binder_kind, typ)] - ] ]; - - Constr.binder: - [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> - ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)])) - | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> - ([id],default_binder_kind, c) - | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> - (id::lid,default_binder_kind, c) - ] ]; - - END - - -type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type - -let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), - (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), - (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = - Genarg.create_arg "subtac_gallina_loc" - -type 'a nameopt_argtype = (identifier option, 'a) Genarg.abstract_argument_type - -let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype), - (globwit_subtac_nameopt : Genarg.glevel nameopt_argtype), - (rawwit_subtac_nameopt : Genarg.rlevel nameopt_argtype) = - Genarg.create_arg "subtac_nameopt" - -VERNAC COMMAND EXTEND Subtac -[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] - END - -VERNAC COMMAND EXTEND Subtac_Obligations -| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, Some t) ] -| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name, None) ] -| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ Subtac_obligations.subtac_obligation (num, None, Some t) ] -| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None, None) ] -| [ "Next" "Obligation" "of" ident(name) ] -> [ Subtac_obligations.next_obligation (Some name) ] -| [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ] -END - -VERNAC COMMAND EXTEND Subtac_Solve_Obligation -| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligation num None (Some (Tacinterp.interp t)) ] - END - -VERNAC COMMAND EXTEND Subtac_Solve_Obligations -| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> - [ Subtac_obligations.try_solve_obligations None None ] - END - -VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations -| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> - [ Subtac_obligations.solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> - [ Subtac_obligations.solve_all_obligations None ] - END - -VERNAC COMMAND EXTEND Subtac_Admit_Obligations -| [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] - END - -VERNAC COMMAND EXTEND Subtac_Set_Solver -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - Coqlib.check_required_library ["Coq";"Program";"Tactics"]; - Tacinterp.add_tacdef false - [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligation_tactic"), true, t)] ] -END - -VERNAC COMMAND EXTEND Subtac_Show_Obligations -| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ] -| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ] -END - -VERNAC COMMAND EXTEND Subtac_Show_Preterm -| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ] -| [ "Preterm" ] -> [ Subtac_obligations.show_term None ] -END diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml deleted file mode 100644 index c0b64379..00000000 --- a/contrib/subtac/subtac.ml +++ /dev/null @@ -1,241 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: subtac.ml 12194 2009-06-17 16:38:09Z msozeau $ *) - -open Global -open Pp -open Util -open Names -open Sign -open Evd -open Term -open Termops -open Reductionops -open Environ -open Type_errors -open Typeops -open Libnames -open Classops -open List -open Recordops -open Evarutil -open Pretype_errors -open Rawterm -open Evarconv -open Pattern -open Dyn -open Vernacexpr - -open Subtac_coercion -open Subtac_utils -open Coqlib -open Printer -open Subtac_errors -open Eterm - -let require_library dirpath = - let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in - Library.require_library [qualid] None - -open Pp -open Ppconstr -open Decl_kinds -open Tacinterp -open Tacexpr - -let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then - let stmt_id = Nameops.add_suffix id "_stmt" in - let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in - match Subtac_obligations.add_definition stmt_id c' typ obls with - Subtac_obligations.Defined cst -> constant_value (Global.env()) - (match cst with ConstRef kn -> kn | _ -> assert false) - | _ -> - errorlabstrm "start_proof" - (str "The statement obligations could not be resolved automatically, " ++ spc () ++ - str "write a statement definition first.") - else - let _ = Typeops.infer_type env c in c - - -let start_proof_com env isevars sopt kind (bl,t) hook = - let id = match sopt with - | Some (loc,id) -> - (* We check existence here: it's a bit late at Qed time *) - if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - user_err_loc (loc,"start_proof",pr_id id ++ str " already exists"); - id - | None -> - next_global_ident_away false (id_of_string "Unnamed_thm") - (Pfedit.get_all_proof_names ()) - in - let evm, c, typ, _imps = - Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None - in - let c = solve_tccs_in_type env id isevars evm c typ in - Command.start_proof id kind c hook - -let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - -let start_proof_and_print env isevars idopt k t hook = - start_proof_com env isevars idopt k t hook; - print_subgoals () - -let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) - -let assumption_message id = - Flags.if_verbose message ((string_of_id id) ^ " is assumed") - -let declare_assumption env isevars idl is_coe k bl c nl = - if not (Pfedit.refining ()) then - let id = snd (List.hd idl) in - let evm, c, typ, imps = - Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None - in - let c = solve_tccs_in_type env id isevars evm c typ in - List.iter (Command.declare_one_assumption is_coe k c imps false [] nl) idl - else - errorlabstrm "Command.Assumption" - (str "Cannot declare an assumption while in proof editing mode.") - -let dump_constraint ty ((loc, n), _, _) = - match n with - | Name id -> Dumpglob.dump_definition (loc, id) false ty - | Anonymous -> () - -let dump_variable lid = () - -let vernac_assumption env isevars kind l nl = - let global = fst kind = Global in - List.iter (fun (is_coe,(idl,c)) -> - if Dumpglob.dump () then - List.iter (fun lid -> - if global then Dumpglob.dump_definition lid (not global) "ax" - else dump_variable lid) idl; - declare_assumption env isevars idl is_coe kind [] c nl) l - -let check_fresh (loc,id) = - if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then - user_err_loc (loc,"",pr_id id ++ str " already exists") - -let subtac (loc, command) = - check_required_library ["Coq";"Init";"Datatypes"]; - check_required_library ["Coq";"Init";"Specif"]; - let env = Global.env () in - let isevars = ref (create_evar_defs Evd.empty) in - try - match command with - | VernacDefinition (defkind, (_, id as lid), expr, hook) -> - check_fresh lid; - Dumpglob.dump_definition lid false "def"; - (match expr with - | ProveBody (bl, t) -> - if Lib.is_modtype () then - errorlabstrm "Subtac_command.StartProof" - (str "Proof editing mode not supported in module types"); - start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) - (fun _ _ -> ()) - | DefineBody (bl, _, c, tycon) -> - ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) - | VernacFixpoint (l, b) -> - List.iter (fun ((lid, _, _, _, _), _) -> - check_fresh lid; - Dumpglob.dump_definition lid false "fix") l; - let _ = trace (str "Building fixpoint") in - ignore(Subtac_command.build_recursive l b) - - | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> - Dumpglob.dump_definition id false "prf"; - if not(Pfedit.refining ()) then - if lettop then - errorlabstrm "Subtac_command.StartProof" - (str "Let declarations can only be used in proof editing mode"); - if Lib.is_modtype () then - errorlabstrm "Subtac_command.StartProof" - (str "Proof editing mode not supported in module types"); - check_fresh id; - start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook - - | VernacAssumption (stre,nl,l) -> - vernac_assumption env isevars stre l nl - - | VernacInstance (glob, sup, is, props, pri) -> - dump_constraint "inst" is; - ignore(Subtac_classes.new_instance ~global:glob sup is props pri) - - | VernacCoFixpoint (l, b) -> - if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; - ignore(Subtac_command.build_corecursive l b) - - (*| VernacEndProof e -> - subtac_end_proof e*) - - | _ -> user_err_loc (loc,"", str ("Invalid Program command")) - with - | Typing_error e -> - msg_warning (str "Type error in Program tactic:"); - let cmds = - (match e with - | NonFunctionalApp (loc, x, mux, e) -> - str "non functional application of term " ++ - e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux - | NonSigma (loc, t) -> - str "Term is not of Sigma type: " ++ t - | NonConvertible (loc, x, y) -> - str "Unconvertible terms:" ++ spc () ++ - x ++ spc () ++ str "and" ++ spc () ++ y - | IllSorted (loc, t) -> - str "Term is ill-sorted:" ++ spc () ++ t - ) - in msg_warning cmds - - | Subtyping_error e -> - msg_warning (str "(Program tactic) Subtyping error:"); - let cmds = - match e with - | UncoercibleInferType (loc, x, y) -> - str "Uncoercible terms:" ++ spc () - ++ x ++ spc () ++ str "and" ++ spc () ++ y - | UncoercibleInferTerm (loc, x, y, tx, ty) -> - str "Uncoercible terms:" ++ spc () - ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x - ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y - | UncoercibleRewrite (x, y) -> - str "Uncoercible terms:" ++ spc () - ++ x ++ spc () ++ str "and" ++ spc () ++ y - in msg_warning cmds - - | Cases.PatternMatchingError (env, exn) as e -> - debug 2 (Himsg.explain_pattern_matching_error env exn); - raise e - - | Type_errors.TypeError (env, exn) as e -> - debug 2 (Himsg.explain_type_error env exn); - raise e - - | Pretype_errors.PretypeError (env, exn) as e -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e - - | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) | - Stdpp.Exc_located (loc, e') as e) -> - debug 2 (str "Parsing exception: "); - (match e' with - | Type_errors.TypeError (env, exn) -> - debug 2 (Himsg.explain_type_error env exn); - raise e - - | Pretype_errors.PretypeError (env, exn) -> - debug 2 (Himsg.explain_pretype_error env exn); - raise e - - | e'' -> raise e) - - | e -> raise e diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli deleted file mode 100644 index b51150aa..00000000 --- a/contrib/subtac/subtac.mli +++ /dev/null @@ -1,2 +0,0 @@ -val require_library : string -> unit -val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml deleted file mode 100644 index bd06407f..00000000 --- a/contrib/subtac/subtac_cases.ml +++ /dev/null @@ -1,2032 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: subtac_cases.ml 12194 2009-06-17 16:38:09Z msozeau $ *) - -open Cases -open Util -open Names -open Nameops -open Term -open Termops -open Declarations -open Inductiveops -open Environ -open Sign -open Reductionops -open Typeops -open Type_errors - -open Rawterm -open Retyping -open Pretype_errors -open Evarutil -open Evarconv - -open Subtac_utils - -(************************************************************************) -(* Pattern-matching compilation (Cases) *) -(************************************************************************) - -(************************************************************************) -(* Configuration, errors and warnings *) - -open Pp - -let mssg_may_need_inversion () = - str "Found a matching with no clauses on a term unknown to have an empty inductive type" - -(* Utils *) -let make_anonymous_patvars = - list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) - -(* Environment management *) -let push_rels vars env = List.fold_right push_rel vars env - -let push_rel_defs = - List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e) - -(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize - over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) - -let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j - -let rec regeneralize_index i k t = match kind_of_term t with - | Rel j when j = i+k -> mkRel (k+1) - | Rel j when j < i+k -> t - | Rel j when j > i+k -> t - | _ -> map_constr_with_binders succ (regeneralize_index i) k t - -type alias_constr = - | DepAlias - | NonDepAlias - -let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = - { uj_val = - (match d with - | DepAlias -> mkLetIn (na,deppat,t,j.uj_val) - | NonDepAlias -> - if (not (dependent (mkRel 1) j.uj_type)) - or (* A leaf: *) isRel deppat - then - (* The body of pat is not needed to type j - see *) - (* insert_aliases - and both deppat and nondeppat have the *) - (* same type, then one can freely substitute one by the other *) - subst1 nondeppat j.uj_val - else - (* The body of pat is not needed to type j but its value *) - (* is dependent in the type of j; our choice is to *) - (* enforce this dependency *) - mkLetIn (na,deppat,t,j.uj_val)); - uj_type = subst1 deppat j.uj_type } - -(**********************************************************************) -(* Structures used in compiling pattern-matching *) - -type rhs = - { rhs_env : env; - avoid_ids : identifier list; - it : rawconstr; - } - -type equation = - { patterns : cases_pattern list; - rhs : rhs; - alias_stack : name list; - eqn_loc : loc; - used : bool ref } - -type matrix = equation list - -(* 1st argument of IsInd is the original ind before extracting the summary *) -type tomatch_type = - | IsInd of types * inductive_type - | NotInd of constr option * types - -type tomatch_status = - | Pushed of ((constr * tomatch_type) * int list) - | Alias of (constr * constr * alias_constr * constr) - | Abstract of rel_declaration - -type tomatch_stack = tomatch_status list - -(* The type [predicate_signature] types the terms to match and the rhs: - - - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]), - if dep<>Anonymous, the term is dependent, let n=|names|, if - n<>0 then the type of the pushed term is necessarily an - inductive with n real arguments. Otherwise, it may be - non inductive, or inductive without real arguments, or inductive - originating from a subterm in which case real args are not dependent; - it accounts for n+1 binders if dep or n binders if not dep - - [PrProd] types abstracted term ([Abstract]); it accounts for one binder - - [PrCcl] types the right-hand-side - - Aliases [Alias] have no trace in [predicate_signature] -*) - -type predicate_signature = - | PrLetIn of (name list * name) * predicate_signature - | PrProd of predicate_signature - | PrCcl of constr - -(* We keep a constr for aliases and a cases_pattern for error message *) - -type alias_builder = - | AliasLeaf - | AliasConstructor of constructor - -type pattern_history = - | Top - | MakeAlias of alias_builder * pattern_continuation - -and pattern_continuation = - | Continuation of int * cases_pattern list * pattern_history - | Result of cases_pattern list - -let start_history n = Continuation (n, [], Top) - -let initial_history = function Continuation (_,[],Top) -> true | _ -> false - -let feed_history arg = function - | Continuation (n, l, h) when n>=1 -> - Continuation (n-1, arg :: l, h) - | Continuation (n, _, _) -> - anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) - | Result _ -> - anomaly "Exhausted pattern history" - -(* This is for non exhaustive error message *) - -let rec rawpattern_of_partial_history args2 = function - | Continuation (n, args1, h) -> - let args3 = make_anonymous_patvars (n - (List.length args2)) in - build_rawpattern (List.rev_append args1 (args2@args3)) h - | Result pl -> pl - -and build_rawpattern args = function - | Top -> args - | MakeAlias (AliasLeaf, rh) -> - assert (args = []); - rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh - | MakeAlias (AliasConstructor pci, rh) -> - rawpattern_of_partial_history - [PatCstr (dummy_loc, pci, args, Anonymous)] rh - -let complete_history = rawpattern_of_partial_history [] - -(* This is to build glued pattern-matching history and alias bodies *) - -let rec simplify_history = function - | Continuation (0, l, Top) -> Result (List.rev l) - | Continuation (0, l, MakeAlias (f, rh)) -> - let pargs = List.rev l in - let pat = match f with - | AliasConstructor pci -> - PatCstr (dummy_loc,pci,pargs,Anonymous) - | AliasLeaf -> - assert (l = []); - PatVar (dummy_loc, Anonymous) in - feed_history pat rh - | h -> h - -(* Builds a continuation expecting [n] arguments and building [ci] applied - to this [n] arguments *) - -let push_history_pattern n current cont = - Continuation (n, [], MakeAlias (current, cont)) - -(* A pattern-matching problem has the following form: - - env, isevars |- <pred> Cases tomatch of mat end - - where tomatch is some sequence of "instructions" (t1 ... tn) - - and mat is some matrix - (p11 ... p1n -> rhs1) - ( ... ) - (pm1 ... pmn -> rhsm) - - Terms to match: there are 3 kinds of instructions - - - "Pushed" terms to match are typed in [env]; these are usually just - Rel(n) except for the initial terms given by user and typed in [env] - - "Abstract" instructions means an abstraction has to be inserted in the - current branch to build (this means a pattern has been detected dependent - in another one and generalisation is necessary to ensure well-typing) - - "Alias" instructions means an alias has to be inserted (this alias - is usually removed at the end, except when its type is not the - same as the type of the matched term from which it comes - - typically because the inductive types are "real" parameters) - - Right-hand-sides: - - They consist of a raw term to type in an environment specific to the - clause they belong to: the names of declarations are those of the - variables present in the patterns. Therefore, they come with their - own [rhs_env] (actually it is the same as [env] except for the names - of variables). - -*) -type pattern_matching_problem = - { env : env; - isevars : Evd.evar_defs ref; - pred : predicate_signature option; - tomatch : tomatch_stack; - history : pattern_continuation; - mat : matrix; - caseloc : loc; - casestyle: case_style; - typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } - -(*--------------------------------------------------------------------------* - * A few functions to infer the inductive type from the patterns instead of * - * checking that the patterns correspond to the ind. type of the * - * destructurated object. Allows type inference of examples like * - * match n with O => true | _ => false end * - * match x in I with C => true | _ => false end * - *--------------------------------------------------------------------------*) - -(* Computing the inductive type from the matrix of patterns *) - -(* We use the "in I" clause to coerce the terms to match and otherwise - use the constructor to know in which type is the matching problem - - Note that insertion of coercions inside nested patterns is done - each time the matrix is expanded *) - -let rec find_row_ind = function - [] -> None - | PatVar _ :: l -> find_row_ind l - | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) - -let inductive_template isevars env tmloc ind = - let arsign = get_full_arity_sign env ind in - let hole_source = match tmloc with - | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) - | None -> fun _ -> (dummy_loc, Evd.InternalHole) in - let (_,evarl,_) = - List.fold_right - (fun (na,b,ty) (subst,evarl,n) -> - match b with - | None -> - let ty' = substl subst ty in - let e = e_new_evar isevars env ~src:(hole_source n) ty' in - (e::subst,e::evarl,n+1) - | Some b -> - (b::subst,evarl,n+1)) - arsign ([],[],1) in - applist (mkInd ind,List.rev evarl) - - -(************************************************************************) -(* Utils *) - -let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars = - e_new_evar isevars env ~src:src (new_Type ()) - -let evd_comb2 f isevars x y = - let (evd',y) = f !isevars x y in - isevars := evd'; - y - - -module Cases_F(Coercion : Coercion.S) : S = struct - -let inh_coerce_to_ind isevars env ty tyi = - let expected_typ = inductive_template isevars env None tyi in - (* devrait être indifférent d'exiger leq ou pas puisque pour - un inductif cela doit être égal *) - let _ = e_cumul env isevars expected_typ ty in () - -let unify_tomatch_with_patterns isevars env loc typ pats = - match find_row_ind pats with - | None -> NotInd (None,typ) - | Some (_,(ind,_)) -> - inh_coerce_to_ind isevars env typ ind; - try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ) - with Not_found -> NotInd (None,typ) - -let find_tomatch_tycon isevars env loc = function - (* Try if some 'in I ...' is present and can be used as a constraint *) - | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind) - | None -> empty_tycon - -let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) = - let loc = Some (loc_of_rawconstr tomatch) in - let tycon = find_tomatch_tycon isevars env loc indopt in - let j = typing_fun tycon env tomatch in - let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in - isevars := evd; - let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in - let t = - try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ) - with Not_found -> - unify_tomatch_with_patterns isevars env loc typ pats in - (j.uj_val,t) - -let coerce_to_indtype typing_fun isevars env matx tomatchl = - let pats = List.map (fun r -> r.patterns) matx in - let matx' = match matrix_transpose pats with - | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) - | m -> m in - List.map2 (coerce_row typing_fun isevars env) matx' tomatchl - - - -let adjust_tomatch_to_pattern pb ((current,typ),deps) = - (* Ideally, we could find a common inductive type to which both the - term to match and the patterns coerce *) - (* In practice, we coerce the term to match if it is not already an - inductive type and it is not dependent; moreover, we use only - the first pattern type and forget about the others *) - let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in - let typ = - try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ) - with Not_found -> NotInd (None,typ) in - let tomatch = ((current,typ),deps) in - match typ with - | NotInd (None,typ) -> - let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in - (match find_row_ind tm1 with - | None -> tomatch - | Some (_,(ind,_)) -> - let indt = inductive_template pb.isevars pb.env None ind in - let current = - if deps = [] & isEvar typ then - (* Don't insert coercions if dependent; only solve evars *) - let _ = e_cumul pb.env pb.isevars indt typ in - current - else - (evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env) - pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in - let sigma = Evd.evars_of !(pb.isevars) in - let typ = IsInd (indt,find_rectype pb.env sigma indt) in - ((current,typ),deps)) - | _ -> tomatch - - (* extract some ind from [t], possibly coercing from constructors in [tm] *) -let to_mutind env isevars tm c t = -(* match c with - | Some body -> *) NotInd (c,t) -(* | None -> unify_tomatch_with_patterns isevars env t tm*) - -let type_of_tomatch = function - | IsInd (t,_) -> t - | NotInd (_,t) -> t - -let mkDeclTomatch na = function - | IsInd (t,_) -> (na,None,t) - | NotInd (c,t) -> (na,c,t) - -let map_tomatch_type f = function - | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind) - | NotInd (c,t) -> NotInd (Option.map f c, f t) - -let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) -let lift_tomatch_type n = liftn_tomatch_type n 1 - -let lift_tomatch n ((current,typ),info) = - ((lift n current,lift_tomatch_type n typ),info) - -(**********************************************************************) -(* Utilities on patterns *) - -let current_pattern eqn = - match eqn.patterns with - | pat::_ -> pat - | [] -> anomaly "Empty list of patterns" - -let alias_of_pat = function - | PatVar (_,name) -> name - | PatCstr(_,_,_,name) -> name - -let unalias_pat = function - | PatVar (c,name) as p -> - if name = Anonymous then p else PatVar (c,Anonymous) - | PatCstr(a,b,c,name) as p -> - if name = Anonymous then p else PatCstr (a,b,c,Anonymous) - -let remove_current_pattern eqn = - match eqn.patterns with - | pat::pats -> - { eqn with - patterns = pats; - alias_stack = alias_of_pat pat :: eqn.alias_stack } - | [] -> anomaly "Empty list of patterns" - -let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } - -(**********************************************************************) -(* Well-formedness tests *) -(* Partial check on patterns *) - -exception NotAdjustable - -let rec adjust_local_defs loc = function - | (pat :: pats, (_,None,_) :: decls) -> - pat :: adjust_local_defs loc (pats,decls) - | (pats, (_,Some _,_) :: decls) -> - PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) - | [], [] -> [] - | _ -> raise NotAdjustable - -let check_and_adjust_constructor env ind cstrs = function - | PatVar _ as pat -> pat - | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> - (* Check it is constructor of the right type *) - let ind' = inductive_of_constructor cstr in - if Closure.mind_equiv env ind' ind then - (* Check the constructor has the right number of args *) - let ci = cstrs.(i-1) in - let nb_args_constr = ci.cs_nargs in - if List.length args = nb_args_constr then pat - else - try - let args' = adjust_local_defs loc (args, List.rev ci.cs_args) - in PatCstr (loc, cstr, args', alias) - with NotAdjustable -> - error_wrong_numarg_constructor_loc loc (Global.env()) - cstr nb_args_constr - else - (* Try to insert a coercion *) - try - Coercion.inh_pattern_coerce_to loc pat ind' ind - with Not_found -> - error_bad_constructor_loc loc cstr ind - -let check_all_variables typ mat = - List.iter - (fun eqn -> match current_pattern eqn with - | PatVar (_,id) -> () - | PatCstr (loc,cstr_sp,_,_) -> - error_bad_pattern_loc loc cstr_sp typ) - mat - -let check_unused_pattern env eqn = - if not !(eqn.used) then - raise_pattern_matching_error - (eqn.eqn_loc, env, UnusedClause eqn.patterns) - -let set_used_pattern eqn = eqn.used := true - -let extract_rhs pb = - match pb.mat with - | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) - | eqn::_ -> - set_used_pattern eqn; - eqn.rhs - -(**********************************************************************) -(* Functions to deal with matrix factorization *) - -let occur_in_rhs na rhs = - match na with - | Anonymous -> false - | Name id -> occur_rawconstr id rhs.it - -let is_dep_patt eqn = function - | PatVar (_,name) -> occur_in_rhs name eqn.rhs - | PatCstr _ -> true - -let dependencies_in_rhs nargs eqns = - if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *) - else - let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in - let columns = matrix_transpose deps in - List.map (List.exists ((=) true)) columns - -let dependent_decl a = function - | (na,None,t) -> dependent a t - | (na,Some c,t) -> dependent a t || dependent a c - -(* Computing the matrix of dependencies *) - -(* We are in context d1...dn |- and [find_dependencies k 1 nextlist] - computes for declaration [k+1] in which of declarations in - [nextlist] (which corresponds to d(k+2)...dn) it depends; - declarations are expressed by index, e.g. in dependency list - [n-2;1], [1] points to [dn] and [n-2] to [d3] *) - -let rec find_dependency_list k n = function - | [] -> [] - | (used,tdeps,d)::rest -> - let deps = find_dependency_list k (n+1) rest in - if used && dependent_decl (mkRel n) d - then list_add_set (List.length rest + 1) (list_union deps tdeps) - else deps - -let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) = - let deps = find_dependency_list k 1 nextlist in - if is_dep_or_cstr_in_rhs || deps <> [] - then (k-1,(true ,deps,d)::nextlist) - else (k-1,(false,[] ,d)::nextlist) - -let find_dependencies_signature deps_in_rhs typs = - let k = List.length deps_in_rhs in - let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in - List.map (fun (_,deps,_) -> deps) l - -(******) - -(* A Pushed term to match has just been substituted by some - constructor t = (ci x1...xn) and the terms x1 ... xn have been added to - match - - - all terms to match and to push (dependent on t by definition) - must have (Rel depth) substituted by t and Rel's>depth lifted by n - - all pushed terms to match (non dependent on t by definition) must - be lifted by n - - We start with depth=1 -*) - -let regeneralize_index_tomatch n = - let rec genrec depth = function - | [] -> [] - | Pushed ((c,tm),l)::rest -> - let c = regeneralize_index n depth c in - let tm = map_tomatch_type (regeneralize_index n depth) tm in - let l = List.map (regeneralize_rel n depth) l in - Pushed ((c,tm),l)::(genrec depth rest) - | Alias (c1,c2,d,t)::rest -> - Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest) - | Abstract d::rest -> - Abstract (map_rel_declaration (regeneralize_index n depth) d) - ::(genrec (depth+1) rest) in - genrec 0 - -let rec replace_term n c k t = - if t = mkRel (n+k) then lift k c - else map_constr_with_binders succ (replace_term n c) k t - -let replace_tomatch n c = - let rec replrec depth = function - | [] -> [] - | Pushed ((b,tm),l)::rest -> - let b = replace_term n c depth b in - let tm = map_tomatch_type (replace_term n c depth) tm in - List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l; - Pushed ((b,tm),l)::(replrec depth rest) - | Alias (c1,c2,d,t)::rest -> - Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest) - | Abstract d::rest -> - Abstract (map_rel_declaration (replace_term n c depth) d) - ::(replrec (depth+1) rest) in - replrec 0 - -let liftn_rel_declaration n k = map_rel_declaration (liftn n k) -let substnl_rel_declaration sigma k = map_rel_declaration (substnl sigma k) - -let rec liftn_tomatch_stack n depth = function - | [] -> [] - | Pushed ((c,tm),l)::rest -> - let c = liftn n depth c in - let tm = liftn_tomatch_type n depth tm in - let l = List.map (fun i -> if i<depth then i else i+n) l in - Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest) - | Alias (c1,c2,d,t)::rest -> - Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t) - ::(liftn_tomatch_stack n depth rest) - | Abstract d::rest -> - Abstract (map_rel_declaration (liftn n depth) d) - ::(liftn_tomatch_stack n (depth+1) rest) - - -let lift_tomatch_stack n = liftn_tomatch_stack n 1 - -(* if [current] has type [I(p1...pn u1...um)] and we consider the case - of constructor [ci] of type [I(p1...pn u'1...u'm)], then the - default variable [name] is expected to have which type? - Rem: [current] is [(Rel i)] except perhaps for initial terms to match *) - -(************************************************************************) -(* Some heuristics to get names for variables pushed in pb environment *) -(* Typical requirement: - - [match y with (S (S x)) => x | x => x end] should be compiled into - [match y with O => y | (S n) => match n with O => y | (S x) => x end end] - - and [match y with (S (S n)) => n | n => n end] into - [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] - - i.e. user names should be preserved and created names should not - interfere with user names *) - -let merge_name get_name obj = function - | Anonymous -> get_name obj - | na -> na - -let merge_names get_name = List.map2 (merge_name get_name) - -let get_names env sign eqns = - let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in - (* If any, we prefer names used in pats, from top to bottom *) - let names2 = - List.fold_right - (fun (pats,eqn) names -> merge_names alias_of_pat pats names) - eqns names1 in - (* Otherwise, we take names from the parameters of the constructor but - avoiding conflicts with user ids *) - let allvars = - List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in - let names4,_ = - List.fold_left2 - (fun (l,avoid) d na -> - let na = - merge_name - (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) - d na - in - (na::l,(out_name na)::avoid)) - ([],allvars) (List.rev sign) names2 in - names4 - -(************************************************************************) -(* Recovering names for variables pushed to the rhs' environment *) - -let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) - -let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in - (n, b, t)) sign - -let push_rels_eqn sign eqn = - let sign = all_name sign in - {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } } - -let push_rels_eqn_with_names sign eqn = - let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in - let sign = recover_alias_names alias_of_pat pats sign in - push_rels_eqn sign eqn - -let build_aliases_context env sigma names allpats pats = - (* pats is the list of bodies to push as an alias *) - (* They all are defined in env and we turn them into a sign *) - (* cuts in sign need to be done in allpats *) - let rec insert env sign1 sign2 n newallpats oldallpats = function - | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) -> - (* Anonymous leaves must be considered named and treated in the *) - (* next clause because they may occur in implicit arguments *) - insert env sign1 sign2 - n newallpats (List.map List.tl oldallpats) (pats,names) - | (deppat,nondeppat,d,t)::pats, na::names -> - let nondeppat = lift n nondeppat in - let deppat = lift n deppat in - let newallpats = - List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in - let oldallpats = List.map List.tl oldallpats in - let decl = (na,Some deppat,t) in - let a = (deppat,nondeppat,d,t) in - insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) - newallpats oldallpats (pats,names) - | [], [] -> newallpats, sign1, sign2, env - | _ -> anomaly "Inconsistent alias and name lists" in - let allpats = List.map (fun x -> [x]) allpats - in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names) - -let insert_aliases_eqn sign eqnnames alias_rest eqn = - let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in - push_rels_eqn thissign { eqn with alias_stack = alias_rest; } - - -let insert_aliases env sigma alias eqns = - (* Là , y a une faiblesse, si un alias est utilisé dans un cas par *) - (* défaut présent mais inutile, ce qui est le cas général, l'alias *) - (* est introduit même s'il n'est pas utilisé dans les cas réguliers *) - let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in - let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in - (* names2 takes the meet of all needed aliases *) - let names2 = - List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in - (* Only needed aliases are kept by build_aliases_context *) - let eqnsnames, sign1, sign2, env = - build_aliases_context env sigma [names2] eqnsnames [alias] in - let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in - sign2, env, eqns - -(**********************************************************************) -(* Functions to deal with elimination predicate *) - -exception Occur -let noccur_between_without_evar n m term = - let rec occur_rec n c = match kind_of_term c with - | Rel p -> if n<=p && p<n+m then raise Occur - | Evar (_,cl) -> () - | _ -> iter_constr_with_binders succ occur_rec n c - in - try occur_rec n term; true with Occur -> false - -(* Inferring the predicate *) -let prepare_unif_pb typ cs = - let n = List.length (assums_of_rel_context cs.cs_args) in - - (* We may need to invert ci if its parameters occur in typ *) - let typ' = - if noccur_between_without_evar 1 n typ then lift (-n) typ - else (* TODO4-1 *) - error "Unable to infer return clause of this pattern-matching problem" in - let args = extended_rel_list (-n) cs.cs_args in - let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in - - (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *) - (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ') - - -(* Infering the predicate *) -(* -The problem to solve is the following: - -We match Gamma |- t : I(u01..u0q) against the following constructors: - - Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q) - ... - Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq) - -Assume the types in the branches are the following - - Gamma, x11...x1p1 |- branch1 : T1 - ... - Gamma, xn1...xnpn |- branchn : Tn - -Assume the type of the global case expression is Gamma |- T - -The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy -the following n+1 equations: - - Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1 - ... - Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn - Gamma |- (phi u01..u0q t) = T - -Some hints: - -- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..." - should be inserted somewhere in Ti. - -- If T is undefined, an easy solution is to insert a "match z with (Ci - xi1..xipi) => ..." in front of each Ti - -- Otherwise, T1..Tn and T must be step by step unified, if some of them - diverge, then try to replace the diverging subterm by one of y1..yq or z. - -- The main problem is what to do when an existential variables is encountered - -let prepare_unif_pb typ cs = - let n = cs.cs_nargs in - let _,p = decompose_prod_n n typ in - let ci = build_dependent_constructor cs in - (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *) - (n, cs.cs_concl_realargs, ci, p) - -let eq_operator_lift k (n,n') = function - | OpRel p, OpRel p' when p > k & p' > k -> - if p < k+n or p' < k+n' then false else p - n = p' - n' - | op, op' -> op = op' - -let rec transpose_args n = - if n=0 then [] - else - (Array.map (fun l -> List.hd l) lv):: - (transpose_args (m-1) (Array.init (fun l -> List.tl l))) - -let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k - -let reloc_operator (k,n) = function OpRel p when p > k -> -let rec unify_clauses k pv = - let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in - let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in - if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv' - then - let argvl = transpose_args (List.length args1) pv' in - let k' = shift_operator k op1 in - let argl = List.map (unify_clauses k') argvl in - gather_constr (reloc_operator (k,n1) op1) argl -*) - -let abstract_conclusion typ cs = - let n = List.length (assums_of_rel_context cs.cs_args) in - let (sign,p) = decompose_prod_n n typ in - lam_it p sign - -let infer_predicate loc env isevars typs cstrs indf = - (* Il faudra substituer les isevars a un certain moment *) - if Array.length cstrs = 0 then (* "TODO4-3" *) - error "Inference of annotation for empty inductive types not implemented" - else - (* Empiric normalization: p may depend in a irrelevant way on args of the*) - (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *) - let typs = - Array.map (local_strong whd_beta (Evd.evars_of !isevars)) typs - in - let eqns = array_map2 prepare_unif_pb typs cstrs in - (* First strategy: no dependencies at all *) -(* - let (mis,_) = dest_ind_family indf in - let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in -*) - let (sign,_) = get_arity env indf in - let mtyp = - if array_exists is_Type typs then - (* Heuristic to avoid comparison between non-variables algebric univs*) - new_Type () - else - mkExistential env ~src:(loc, Evd.CasesType) isevars - in - if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns - then - (* Non dependent case -> turn it into a (dummy) dependent one *) - let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in - let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in - (true,pred) (* true = dependent -- par défaut *) - else -(* - let s = get_sort_of env (evars_of isevars) typs.(0) in - let predpred = it_mkLambda_or_LetIn (mkSort s) sign in - let caseinfo = make_default_case_info mis in - let brs = array_map2 abstract_conclusion typs cstrs in - let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in - let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in -*) - (* "TODO4-2" *) - (* We skip parameters *) - let cis = - Array.map - (fun cs -> - applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) - cstrs in - let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in - raise_pattern_matching_error (loc,env, CannotInferPredicate ct) -(* - (true,pred) -*) - -(* Propagation of user-provided predicate through compilation steps *) - -let rec map_predicate f k = function - | PrCcl ccl -> PrCcl (f k ccl) - | PrProd pred -> - PrProd (map_predicate f (k+1) pred) - | PrLetIn ((names,dep as tm),pred) -> - let k' = List.length names + (if dep<>Anonymous then 1 else 0) in - PrLetIn (tm, map_predicate f (k+k') pred) - -let rec noccurn_predicate k = function - | PrCcl ccl -> noccurn k ccl - | PrProd pred -> noccurn_predicate (k+1) pred - | PrLetIn ((names,dep),pred) -> - let k' = List.length names + (if dep<>Anonymous then 1 else 0) in - noccurn_predicate (k+k') pred - -let liftn_predicate n = map_predicate (liftn n) - -let lift_predicate n = liftn_predicate n 1 - -let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0 - -let substnl_predicate sigma = map_predicate (substnl sigma) - -(* This is parallel bindings *) -let subst_predicate (args,copt) pred = - let sigma = match copt with - | None -> List.rev args - | Some c -> c::(List.rev args) in - substnl_predicate sigma 0 pred - -let specialize_predicate_var (cur,typ) = function - | PrProd _ | PrCcl _ -> - anomaly "specialize_predicate_var: a pattern-variable must be pushed" - | PrLetIn (([],dep),pred) -> - subst_predicate ([],if dep<>Anonymous then Some cur else None) pred - | PrLetIn ((_,dep),pred) -> - (match typ with - | IsInd (_,IndType (_,realargs)) -> - subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred - | _ -> anomaly "specialize_predicate_var") - -let ungeneralize_predicate = function - | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product" - | PrProd pred -> pred - -(*****************************************************************************) -(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *) -(* and we want to abstract P over y:t(x) typed in the same context to get *) -(* *) -(* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *) -(* *) -(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) -(* then we have to replace x by x' in t(x) and y by y' in P *) -(*****************************************************************************) -let generalize_predicate ny d = function - | PrLetIn ((names,dep as tm),pred) -> - if dep=Anonymous then anomaly "Undetected dependency"; - let p = List.length names + 1 in - let pred = lift_predicate 1 pred in - let pred = regeneralize_index_predicate (ny+p+1) pred in - PrLetIn (tm, PrProd pred) - | PrProd _ | PrCcl _ -> - anomaly "generalize_predicate: expects a non trivial pattern" - -let rec extract_predicate l = function - | pred, Alias (deppat,nondeppat,_,_)::tms -> - let tms' = match kind_of_term nondeppat with - | Rel i -> replace_tomatch i deppat tms - | _ -> (* initial terms are not dependent *) tms in - extract_predicate l (pred,tms') - | PrProd pred, Abstract d'::tms -> - let d' = map_rel_declaration (lift (List.length l)) d' in - substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms))) - | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms -> - extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) - | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms -> - let l = List.rev realargs@l in - extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms) - | PrCcl ccl, [] -> - substl l ccl - | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match" - -let abstract_predicate env sigma indf cur tms = function - | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn" - | PrLetIn ((names,dep),pred) -> - let sign = make_arity_signature env true indf in - (* n is the number of real args + 1 *) - let n = List.length sign in - let tms = lift_tomatch_stack n tms in - let tms = - match kind_of_term cur with - | Rel i -> regeneralize_index_tomatch (i+n) tms - | _ -> (* Initial case *) tms in - (* Depending on whether the predicate is dependent or not, and has real - args or not, we lift it to make room for [sign] *) - (* Even if not intrinsically dep, we move the predicate into a dep one *) - let sign,k = - if names = [] & n <> 1 then - (* Real args were not considered *) - (if dep<>Anonymous then - ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1) - else - (sign,n)) - else - (* Real args are OK *) - (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign, - if dep<>Anonymous then 0 else 1) in - let pred = lift_predicate k pred in - let pred = extract_predicate [] (pred,tms) in - (true, it_mkLambda_or_LetIn_name env pred sign) - -let rec known_dependent = function - | None -> false - | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous - | Some (PrCcl _) -> false - | Some (PrProd _) -> - anomaly "known_dependent: can only be used when patterns remain" - -(* [expand_arg] is used by [specialize_predicate] - it replaces gamma, x1...xn, x1...xk |- pred - by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or - by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) - -let expand_arg n alreadydep (na,t) deps (k,pred) = - (* current can occur in pred even if the original problem is not dependent *) - let dep = - if alreadydep<>Anonymous then alreadydep - else if deps = [] && noccurn_predicate 1 pred then Anonymous - else Name (id_of_string "x") in - let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in - (* There is no dependency in realargs for subpattern *) - (k-1, PrLetIn (([],dep), pred)) - - -(*****************************************************************************) -(* pred = [X:=realargs;x:=c]P types the following problem: *) -(* *) -(* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *) -(* *) -(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *) -(* is considered. Assume each Ti is some Ii(argsi). *) -(* We let e=Ci(x1,...,xn) and replace pred by *) -(* *) -(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *) -(* *) -(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*) -(* *) -(*****************************************************************************) -let specialize_predicate tomatchs deps cs = function - | (PrProd _ | PrCcl _) -> - anomaly "specialize_predicate: a matched pattern must be pushed" - | PrLetIn ((names,isdep),pred) -> - (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *) - let nrealargs = List.length names in - let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in - (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *) - let n = cs.cs_nargs in - let pred' = liftn_predicate n (k+1) pred in - let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in - let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in - (* The substituends argsi, copti are all defined in gamma, x1...xn *) - (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *) - let pred'' = subst_predicate (argsi, copti) pred' in - (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *) - let pred''' = liftn_predicate n (n+1) pred'' in - (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*) - snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred''')) - -let find_predicate loc env isevars p typs cstrs current - (IndType (indf,realargs)) tms = - let (dep,pred) = - match p with - | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p - | None -> infer_predicate loc env isevars typs cstrs indf in - let typ = whd_beta (Evd.evars_of !isevars) (applist (pred, realargs)) in - if dep then - (pred, whd_beta (Evd.evars_of !isevars) (applist (typ, [current])), - new_Type ()) - else - (pred, typ, new_Type ()) - -(************************************************************************) -(* Sorting equations by constructor *) - -type inversion_problem = - (* the discriminating arg in some Ind and its order in Ind *) - | Incompatible of int * (int * int) - | Constraints of (int * constr) list - -let solve_constraints constr_info indt = - (* TODO *) - Constraints [] - -let rec irrefutable env = function - | PatVar (_,name) -> true - | PatCstr (_,cstr,args,_) -> - let ind = inductive_of_constructor cstr in - let (_,mip) = Inductive.lookup_mind_specif env ind in - let one_constr = Array.length mip.mind_user_lc = 1 in - one_constr & List.for_all (irrefutable env) args - -let first_clause_irrefutable env = function - | eqn::mat -> List.for_all (irrefutable env) eqn.patterns - | _ -> false - -let group_equations pb ind current cstrs mat = - let mat = - if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in - let brs = Array.create (Array.length cstrs) [] in - let only_default = ref true in - let _ = - List.fold_right (* To be sure it's from bottom to top *) - (fun eqn () -> - let rest = remove_current_pattern eqn in - let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | PatVar (_,name) -> - (* This is a default clause that we expand *) - for i=1 to Array.length cstrs do - let n = cstrs.(i-1).cs_nargs in - let args = make_anonymous_patvars n in - brs.(i-1) <- (args, rest) :: brs.(i-1) - done - | PatCstr (loc,((_,i)),args,_) -> - (* This is a regular clause *) - only_default := false; - brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in - (brs,!only_default) - -(************************************************************************) -(* Here starts the pattern-matching compilation algorithm *) - -(* Abstracting over dependent subterms to match *) -let rec generalize_problem pb = function - | [] -> pb - | i::l -> - let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in - let pb' = generalize_problem pb l in - let tomatch = lift_tomatch_stack 1 pb'.tomatch in - let tomatch = regeneralize_index_tomatch (i+1) tomatch in - { pb with - tomatch = Abstract d :: tomatch; - pred = Option.map (generalize_predicate i d) pb'.pred } - -(* No more patterns: typing the right-hand-side of equations *) -let build_leaf pb = - let rhs = extract_rhs pb in - let tycon = match pb.pred with - | None -> anomaly "Predicate not found" - | Some (PrCcl typ) -> mk_tycon typ - | Some _ -> anomaly "not all parameters of pred have been consumed" in - pb.typing_function tycon rhs.rhs_env rhs.it - -(* Building the sub-problem when all patterns are variables *) -let shift_problem (current,t) pb = - {pb with - tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch; - pred = Option.map (specialize_predicate_var (current,t)) pb.pred; - history = push_history_pattern 0 AliasLeaf pb.history; - mat = List.map remove_current_pattern pb.mat } - -(* Building the sub-pattern-matching problem for a given branch *) -let build_branch current deps pb eqns const_info = - (* We remember that we descend through a constructor *) - let alias_type = - if Array.length const_info.cs_concl_realargs = 0 - & not (known_dependent pb.pred) & deps = [] - then - NonDepAlias - else - DepAlias - in - let history = - push_history_pattern const_info.cs_nargs - (AliasConstructor const_info.cs_cstr) - pb.history in - - (* We find matching clauses *) - let cs_args = (*assums_of_rel_context*) const_info.cs_args in - let names = get_names pb.env cs_args eqns in - let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in - if submat = [] then - raise_pattern_matching_error - (dummy_loc, pb.env, NonExhaustive (complete_history history)); - let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in - let _,typs',_ = - List.fold_right - (fun (na,c,t as d) (env,typs,tms) -> - let tm1 = List.map List.hd tms in - let tms = List.map List.tl tms in - (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms)) - typs (pb.env,[],List.map fst eqns) in - - let dep_sign = - find_dependencies_signature - (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in - - (* The dependent term to subst in the types of the remaining UnPushed - terms is relative to the current context enriched by topushs *) - let ci = build_dependent_constructor const_info in - - (* We replace [(mkRel 1)] by its expansion [ci] *) - (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *) - (* This is done in two steps : first from "Gamma |- tms" *) - (* into "Gamma; typs; curalias |- tms" *) - let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in - - let currents = - list_map2_i - (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps)) - 1 typs' (List.rev dep_sign) in - - let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in - let ind = - appvect ( - applist (mkInd (inductive_of_constructor const_info.cs_cstr), - List.map (lift const_info.cs_nargs) const_info.cs_params), - const_info.cs_concl_realargs) in - - let cur_alias = lift (List.length sign) current in - let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in - let env' = push_rels sign pb.env in - let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in - sign, - { pb with - env = env'; - tomatch = List.rev_append currents tomatch; - pred = pred'; - history = history; - mat = List.map (push_rels_eqn_with_names sign) submat } - -(********************************************************************** - INVARIANT: - - pb = { env, subst, tomatch, mat, ...} - tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T) - - "Pushed" terms and types are relative to env - "Abstract" types are relative to env enriched by the previous terms to match - -*) - -(**********************************************************************) -(* Main compiling descent *) -let rec compile pb = - match pb.tomatch with - | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur - | (Alias x)::rest -> compile_alias pb x rest - | (Abstract d)::rest -> compile_generalization pb d rest - | [] -> build_leaf pb - -and match_current pb tomatch = - let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in - match typ with - | NotInd (_,typ) -> - check_all_variables typ pb.mat; - compile (shift_problem ct pb) - | IsInd (_,(IndType(indf,realargs) as indt)) -> - let mind,_ = dest_ind_family indf in - let cstrs = get_constructors pb.env indf in - let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in - if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then - compile (shift_problem ct pb) - else - let _constraints = Array.map (solve_constraints indt) cstrs in - - (* We generalize over terms depending on current term to match *) - let pb = generalize_problem pb deps in - - (* We compile branches *) - let brs = array_map2 (compile_branch current deps pb) eqns cstrs in - - (* We build the (elementary) case analysis *) - let brvals = Array.map (fun (v,_) -> v) brs in - let brtyps = Array.map (fun (_,t) -> t) brs in - let (pred,typ,s) = - find_predicate pb.caseloc pb.env pb.isevars - pb.pred brtyps cstrs current indt pb.tomatch in - let ci = make_case_info pb.env mind pb.casestyle in - let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in - let inst = List.map mkRel deps in - { uj_val = applist (case, inst); - uj_type = substl inst typ } - -and compile_branch current deps pb eqn cstr = - let sign, pb = build_branch current deps pb eqn cstr in - let j = compile pb in - (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type) - -and compile_generalization pb d rest = - let pb = - { pb with - env = push_rel d pb.env; - tomatch = rest; - pred = Option.map ungeneralize_predicate pb.pred; - mat = List.map (push_rels_eqn [d]) pb.mat } in - let j = compile pb in - { uj_val = mkLambda_or_LetIn d j.uj_val; - uj_type = mkProd_or_LetIn d j.uj_type } - -and compile_alias pb (deppat,nondeppat,d,t) rest = - let history = simplify_history pb.history in - let sign, newenv, mat = - insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in - let n = List.length sign in - - (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *) - (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *) - let tomatch = lift_tomatch_stack n rest in - let tomatch = match kind_of_term nondeppat with - | Rel i -> - if n = 1 then regeneralize_index_tomatch (i+n) tomatch - else replace_tomatch i deppat tomatch - | _ -> (* initial terms are not dependent *) tomatch in - - let pb = - {pb with - env = newenv; - tomatch = tomatch; - pred = Option.map (lift_predicate n) pb.pred; - history = history; - mat = mat } in - let j = compile pb in - List.fold_left mkSpecialLetInJudge j sign - -(* pour les alias des initiaux, enrichir les env de ce qu'il faut et -substituer après par les initiaux *) - -(**************************************************************************) -(* Preparation of the pattern-matching problem *) - -(* builds the matrix of equations testing that each eqn has n patterns - * and linearizing the _ patterns. - * Syntactic correctness has already been done in astterm *) -let matx_of_eqns env eqns = - let build_eqn (loc,ids,lpat,rhs) = - let rhs = - { rhs_env = env; - avoid_ids = ids@(ids_of_named_context (named_context env)); - it = rhs; - } in - { patterns = lpat; - alias_stack = []; - eqn_loc = loc; - used = ref false; - rhs = rhs } - in List.map build_eqn eqns - -(************************************************************************) -(* preparing the elimination predicate if any *) - -let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = - let cook (n, l, env, signs) = function - | c,IsInd (_,IndType(indf,realargs)) -> - let indf' = lift_inductive_family n indf in - let sign = make_arity_signature env dep indf' in - let p = List.length realargs in - if dep then - (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs) - else - (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs) - | c,NotInd _ -> - (n, l, env, []::signs) in - let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in - let names = List.rev (List.map (List.map pi1) signs) in - let allargs = - List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in - let rec build_skeleton env c = - (* Don't put into normal form, it has effects on the synthesis of evars *) - (* let c = whd_betadeltaiota env (evars_of isevars) c in *) - (* We turn all subterms possibly dependent into an evar with maximum ctxt*) - if isEvar c or List.exists (eq_constr c) allargs then - e_new_evar isevars env ~src:(loc, Evd.CasesType) - (Retyping.get_type_of env (Evd.evars_of !isevars) c) - else - map_constr_with_full_binders push_rel build_skeleton env c - in - names, build_skeleton env (lift n c) - -(* Here, [pred] is assumed to be in the context built from all *) -(* realargs and terms to match *) -let build_initial_predicate isdep allnames pred = - let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let rec buildrec n pred = function - | [] -> PrCcl pred - | names::lnames -> - let names' = if isdep then List.tl names else names in - let n' = n + List.length names' in - let pred, p, user_p = - if isdep then - if dependent (mkRel (nar-n')) pred then pred, 1, 1 - else liftn (-1) (nar-n') pred, 0, 1 - else pred, 0, 0 in - let na = - if p=1 then - let na = List.hd names in - if na = Anonymous then - (* peut arriver en raison des evars *) - Name (id_of_string "x") (*Hum*) - else na - else Anonymous in - PrLetIn ((names',na), buildrec (n'+user_p) pred lnames) - in buildrec 0 pred allnames - -let extract_arity_signature env0 tomatchl tmsign = - let get_one_sign n tm (na,t) = - match tm with - | NotInd (bo,typ) -> - (match t with - | None -> [na,Option.map (lift n) bo,lift n typ] - | Some (loc,_,_,_) -> - user_err_loc (loc,"", - str "Unexpected type annotation for a term of non inductive type")) - | IsInd (_,IndType(indf,realargs)) -> - let indf' = lift_inductive_family n indf in - let (ind,params) = dest_ind_family indf' in - let nrealargs = List.length realargs in - let realnal = - match t with - | Some (loc,ind',nparams,realnal) -> - if ind <> ind' then - user_err_loc (loc,"",str "Wrong inductive type"); - if List.length params <> nparams - or nrealargs <> List.length realnal then - anomaly "Ill-formed 'in' clause in cases"; - List.rev realnal - | None -> list_tabulate (fun _ -> Anonymous) nrealargs in - let arsign = fst (get_arity env0 indf') in - (na,None,build_dependent_inductive env0 indf') - ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in - let rec buildrec n = function - | [],[] -> [] - | (_,tm)::ltm, x::tmsign -> - let l = get_one_sign n tm x in - l :: buildrec (n + List.length l) (ltm,tmsign) - | _ -> assert false - in List.rev (buildrec 0 (tomatchl,tmsign)) - -let extract_arity_signatures env0 tomatchl tmsign = - let get_one_sign tm (na,t) = - match tm with - | NotInd (bo,typ) -> - (match t with - | None -> [na,bo,typ] - | Some (loc,_,_,_) -> - user_err_loc (loc,"", - str "Unexpected type annotation for a term of non inductive type")) - | IsInd (_,IndType(indf,realargs)) -> - let (ind,params) = dest_ind_family indf in - let nrealargs = List.length realargs in - let realnal = - match t with - | Some (loc,ind',nparams,realnal) -> - if ind <> ind' then - user_err_loc (loc,"",str "Wrong inductive type"); - if List.length params <> nparams - or nrealargs <> List.length realnal then - anomaly "Ill-formed 'in' clause in cases"; - List.rev realnal - | None -> list_tabulate (fun _ -> Anonymous) nrealargs in - let arsign = fst (get_arity env0 indf) in - (na,None,build_dependent_inductive env0 indf) - ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in - let rec buildrec = function - | [],[] -> [] - | (_,tm)::ltm, x::tmsign -> - let l = get_one_sign tm x in - l :: buildrec (ltm,tmsign) - | _ -> assert false - in List.rev (buildrec (tomatchl,tmsign)) - -let inh_conv_coerce_to_tycon loc env isevars j tycon = - match tycon with - | Some p -> - let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in - isevars := evd'; - j - | None -> j - -let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) - -let string_of_name name = - match name with - | Anonymous -> "anonymous" - | Name n -> string_of_id n - -let id_of_name n = id_of_string (string_of_name n) - -let make_prime_id name = - let str = string_of_name name in - id_of_string str, id_of_string (str ^ "'") - -let prime avoid name = - let previd, id = make_prime_id name in - previd, next_ident_away_from id avoid - -let make_prime avoid prevname = - let previd, id = prime !avoid prevname in - avoid := id :: !avoid; - previd, id - -let eq_id avoid id = - let hid = id_of_string ("Heq_" ^ string_of_id id) in - let hid' = next_ident_away_from hid avoid in - hid' - -let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) - -let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) - -let context_of_arsign l = - let (x, _) = List.fold_right - (fun c (x, n) -> - (lift_rel_context n c @ x, List.length c + n)) - l ([], 0) - in x - -let constr_of_pat env isevars arsign pat avoid = - let rec typ env (ty, realargs) pat avoid = - match pat with - | PatVar (l,name) -> - let name, avoid = match name with - Name n -> name, avoid - | Anonymous -> - let previd, id = prime avoid (Name (id_of_string "wildcard")) in - Name id, id :: avoid - in - PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid - | PatCstr (l,((_, i) as cstr),args,alias) -> - let cind = inductive_of_constructor cstr in - let IndType (indf, _) = find_rectype env (Evd.evars_of !isevars) (lift (-(List.length realargs)) ty) in - let ind, params = dest_ind_family indf in - if ind <> cind then error_bad_constructor_loc l cstr ind; - let cstrs = get_constructors env indf in - let ci = cstrs.(i-1) in - let nb_args_constr = ci.cs_nargs in - assert(nb_args_constr = List.length args); - let patargs, args, sign, env, n, m, avoid = - List.fold_right2 - (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> - let pat', sign', arg', typ', argtypargs, n', avoid = - typ env (lift (n - m) t, []) ua avoid - in - let args' = arg' :: List.map (lift n') args in - let env' = push_rels sign' env in - (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) - ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) - in - let args = List.rev args in - let patargs = List.rev patargs in - let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstruct ci.cs_cstr in - let app = applistc cstr (List.map (lift (List.length sign)) params) in - let app = applistc app args in - let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in - let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in - match alias with - Anonymous -> - pat', sign, app, apptype, realargs, n, avoid - | Name id -> - let sign = (alias, None, lift m ty) :: sign in - let avoid = id :: avoid in - let sign, i, avoid = - try - let env = push_rels sign env in - isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars; - let eq_t = mk_eq (lift (succ m) ty) - (mkRel 1) (* alias *) - (lift 1 app) (* aliased term *) - in - let neq = eq_id avoid id in - (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid - with Reduction.NotConvertible -> sign, 1, avoid - in - (* Mark the equality as a hole *) - pat', sign, lift i app, lift i apptype, realargs, n + i, avoid - in - let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid - - -(* shadows functional version *) -let eq_id avoid id = - let hid = id_of_string ("Heq_" ^ string_of_id id) in - let hid' = next_ident_away_from hid !avoid in - avoid := hid' :: !avoid; - hid' - -let rels_of_patsign = - List.map (fun ((na, b, t) as x) -> - match b with - | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) - | _ -> x) - -let vars_of_ctx ctx = - let _, y = - List.fold_right (fun (na, b, t) (prev, vars) -> - match b with - | Some t' when kind_of_term t' = Rel 0 -> - prev, - (RApp (dummy_loc, - (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars - | _ -> - match na with - Anonymous -> raise (Invalid_argument "vars_of_ctx") - | Name n -> n, RVar (dummy_loc, n) :: vars) - ctx (id_of_string "vars_of_ctx_error", []) - in List.rev y - -let rec is_included x y = - match x, y with - | PatVar _, _ -> true - | _, PatVar _ -> true - | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') -> - if i = i' then List.for_all2 is_included args args' - else false - -(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its - full signature. However prevpatterns are in the original one signature per pattern form. - *) -let build_ineqs prevpatterns pats liftsign = - let _tomatchs = List.length pats in - let diffs = - List.fold_left - (fun c eqnpats -> - let acc = List.fold_left2 - (* ppat is the pattern we are discriminating against, curpat is the current one. *) - (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) - (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> - match acc with - None -> None - | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) - if is_included curpat ppat then - (* Length of previous pattern's signature *) - let lens = List.length ppat_sign in - (* Accumulated length of previous pattern's signatures *) - let len' = lens + len in - let acc = - ((* Jump over previous prevpat signs *) - lift_rel_context len ppat_sign @ sign, - len', - succ n, (* nth pattern *) - mkApp (Lazy.force eq_ind, - [| lift (len' + liftsign) curpat_ty; - liftn (len + liftsign) (succ lens) ppat_c ; - lift len' curpat_c |]) :: - List.map (lift lens (* Jump over this prevpat signature *)) c) - in Some acc - else None) - (Some ([], 0, 0, [])) eqnpats pats - in match acc with - None -> c - | Some (sign, len, _, c') -> - let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) - (lift_rel_context liftsign sign) - in - conj :: c) - [] prevpatterns - in match diffs with [] -> None - | _ -> Some (mk_conj diffs) - -let subst_rel_context k ctx subst = - let (_, ctx') = - List.fold_right - (fun (n, b, t) (k, acc) -> - (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) - ctx (k, []) - in ctx' - -let lift_rel_contextn n k sign = - let rec liftrec k = function - | (na,c,t)::sign -> - (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) - | [] -> [] - in - liftrec (rel_context_length sign + k) sign - -let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = - let i = ref 0 in - let (x, y, z) = - List.fold_left - (fun (branches, eqns, prevpatterns) eqn -> - let _, newpatterns, pats = - List.fold_left2 - (fun (idents, newpatterns, pats) pat arsign -> - let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in - (idents, pat' :: newpatterns, cpat :: pats)) - ([], [], []) eqn.patterns sign - in - let newpatterns = List.rev newpatterns and opats = List.rev pats in - let rhs_rels, pats, signlen = - List.fold_left - (fun (renv, pats, n) (sign,c, (s, args), p) -> - (* Recombine signatures and terms of all of the row's patterns *) - let sign' = lift_rel_context n sign in - let len = List.length sign' in - (sign' @ renv, - (* lift to get outside of previous pattern's signatures. *) - (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, - len + n)) - ([], [], 0) opats in - let pats, _ = List.fold_left - (* lift to get outside of past patterns to get terms in the combined environment. *) - (fun (pats, n) (sign, c, (s, args), p) -> - let len = List.length sign in - ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) - ([], 0) pats - in - let ineqs = build_ineqs prevpatterns pats signlen in - let rhs_rels' = rels_of_patsign rhs_rels in - let _signenv = push_rel_context rhs_rels' env in - let arity = - let args, nargs = - List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> - (args @ c :: allargs, List.length args + succ n)) - pats ([], 0) - in - let args = List.rev args in - substl args (liftn signlen (succ nargs) arity) - in - let rhs_rels', tycon = - let neqs_rels, arity = - match ineqs with - | None -> [], arity - | Some ineqs -> - [Anonymous, None, ineqs], lift 1 arity - in - let eqs_rels, arity = decompose_prod_n_assum neqs arity in - eqs_rels @ neqs_rels @ rhs_rels', arity - in - let rhs_env = push_rels rhs_rels' env in - let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in - let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' - and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in - let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in - let branch = - let bref = RVar (dummy_loc, branch_name) in - match vars_of_ctx rhs_rels with - [] -> bref - | l -> RApp (dummy_loc, bref, l) - in - let branch = match ineqs with - Some _ -> RApp (dummy_loc, branch, [ hole ]) - | None -> branch - in - incr i; - let rhs = { eqn.rhs with it = branch } in - (branch_decl :: branches, - { eqn with patterns = newpatterns; rhs = rhs } :: eqns, - opats :: prevpatterns)) - ([], [], []) eqns - in x, y - -(* Builds the predicate. If the predicate is dependent, its context is - * made of 1+nrealargs assumptions for each matched term in an inductive - * type and 1 assumption for each term not _syntactically_ in an - * inductive type. - - * Each matched terms are independently considered dependent or not. - - * A type constraint but no annotation case: it is assumed non dependent. - *) - -let lift_ctx n ctx = - let ctx', _ = - List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) - in ctx' - -(* Turn matched terms into variables. *) -let abstract_tomatch env tomatchs = - let prev, ctx, names = - List.fold_left - (fun (prev, ctx, names) (c, t) -> - let lenctx = List.length ctx in - match kind_of_term c with - Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names - | _ -> - let name = next_ident_away_from (id_of_string "filtered_var") names in - (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, - name :: names) - ([], [], []) tomatchs - in List.rev prev, ctx - -let is_dependent_ind = function - IsInd (_, IndType (indf, args)) when List.length args > 0 -> true - | _ -> false - -let build_dependent_signature env evars avoid tomatchs arsign = - let avoid = ref avoid in - let arsign = List.rev arsign in - let allnames = List.rev (List.map (List.map pi1) arsign) in - let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let eqs, neqs, refls, slift, arsign' = - List.fold_left2 - (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> - (* The accumulator: - previous eqs, - number of previous eqs, - lift to get outside eqs and in the introduced variables ('as' and 'in'), - new arity signatures - *) - match ty with - IsInd (ty, IndType (indf, args)) when List.length args > 0 -> - (* Build the arity signature following the names in matched terms as much as possible *) - let argsign = List.tl arsign in (* arguments in inverse application order *) - let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) - let argsign = List.rev argsign in (* arguments in application order *) - let env', nargeqs, argeqs, refl_args, slift, argsign' = - List.fold_left2 - (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> - let argt = Retyping.get_type_of env evars arg in - let eq, refl_arg = - if Reductionops.is_conv env evars argt t then - (mk_eq (lift (nargeqs + slift) argt) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) arg), - mk_eq_refl argt arg) - else - (mk_JMeq (lift (nargeqs + slift) t) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) argt) - (lift (nargeqs + nar) arg), - mk_JMeq_refl argt arg) - in - let previd, id = - let name = - match kind_of_term arg with - Rel n -> pi1 (Environ.lookup_rel n env) - | _ -> name - in - make_prime avoid name - in - (env, succ nargeqs, - (Name (eq_id avoid previd), None, eq) :: argeqs, - refl_arg :: refl_args, - pred slift, - (Name id, b, t) :: argsign')) - (env, 0, [], [], slift, []) args argsign - in - let eq = mk_JMeq - (lift (nargeqs + slift) appt) - (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) ty) - (lift (nargeqs + nar) tm) - in - let refl_eq = mk_JMeq_refl ty tm in - let previd, id = make_prime avoid appn in - (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, - succ nargeqs, - refl_eq :: refl_args, - pred slift, - (((Name id, appb, appt) :: argsign') :: arsigns)) - - | _ -> - (* Non dependent inductive or not inductive, just use a regular equality *) - let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in - let previd, id = make_prime avoid name in - let arsign' = (Name id, b, typ) in - let tomatch_ty = type_of_tomatch ty in - let eq = - mk_eq (lift nar tomatch_ty) - (mkRel slift) (lift nar tm) - in - ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, - (mk_eq_refl tomatch_ty tm) :: refl_args, - pred slift, (arsign' :: []) :: arsigns)) - ([], 0, [], nar, []) tomatchs arsign - in - let arsign'' = List.rev arsign' in - assert(slift = 0); (* we must have folded over all elements of the arity signature *) - arsign'', allnames, nar, eqs, neqs, refls - -(**************************************************************************) -(* Main entry of the matching compilation *) - -let liftn_rel_context n k sign = - let rec liftrec k = function - | (na,c,t)::sign -> - (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) - | [] -> [] - in - liftrec (k + rel_context_length sign) sign - -let nf_evars_env evar_defs (env : env) : env = - let nf t = nf_isevar evar_defs t in - let env0 : env = reset_context env in - let f e (na, b, t) e' : env = - Environ.push_named (na, Option.map nf b, nf t) e' - in - let env' = Environ.fold_named_context f ~init:env0 env in - Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e') - ~init:env' env - -(* We put the tycon inside the arity signature, possibly discovering dependencies. *) - -let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = - let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in - let subst, len = - List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> - let signlen = List.length sign in - match kind_of_term tm with - | Rel n when dependent tm c - && signlen = 1 (* The term to match is not of a dependent type itself *) -> - ((n, len) :: subst, len - signlen) - | Rel _ when not (dependent tm c) - && signlen > 1 (* The term is of a dependent type but does not appear in - the tycon, maybe some variable in its type does. *) -> - (match tmtype with - NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) - | IsInd (_, IndType(indf,realargs)) -> - List.fold_left - (fun (subst, len) arg -> - match kind_of_term arg with - | Rel n when dependent arg c -> - ((n, len) :: subst, pred len) - | _ -> (subst, pred len)) - (subst, len) realargs) - | _ -> (subst, len - signlen)) - ([], nar) tomatchs arsign - in - let rec predicate lift c = - match kind_of_term c with - | Rel n when n > lift -> - (try - (* Make the predicate dependent on the matched variable *) - let idx = List.assoc (n - lift) subst in - mkRel (idx + lift) - with Not_found -> - (* A variable that is not matched, lift over the arsign. *) - mkRel (n + nar)) - | _ -> - map_constr_with_binders succ predicate lift c - in - try - (* The tycon may be ill-typed after abstraction. *) - let pred = predicate 0 c in - let env' = push_rel_context (context_of_arsign arsign) env in - ignore(Typing.sort_of env' evm pred); pred - with _ -> lift nar c - - -let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = - (* We extract the signature of the arity *) - let arsign = extract_arity_signature env tomatchs sign in - let newenv = List.fold_right push_rels arsign env in - let allnames = List.rev (List.map (List.map pi1) arsign) in - match rtntyp with - | Some rtntyp -> - let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in - let predccl = (j_nf_isevar !isevars predcclj).uj_val in - Some (build_initial_predicate true allnames predccl) - | None -> - match valcon_of_tycon tycon with - | Some ty -> - let pred = - prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars) tomatchs arsign ty - in Some (build_initial_predicate true allnames pred) - | None -> None - -let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = - - let typing_fun tycon env = typing_fun tycon env isevars in - - (* We build the matrix of patterns and right-hand-side *) - let matx = matx_of_eqns env eqns in - - (* We build the vector of terms to match consistently with the *) - (* constructors found in patterns *) - let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in - let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in - if predopt = None then - let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in - let tomatchs_len = List.length tomatchs_lets in - let env = push_rel_context tomatchs_lets env in - let len = List.length eqns in - let sign, allnames, signlen, eqs, neqs, args = - (* The arity signature *) - let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in - (* Build the dependent arity signature, the equalities which makes - the first part of the predicate and their instantiations. *) - let avoid = [] in - build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign - - in - let tycon, arity = - match valcon_of_tycon tycon with - | None -> let ev = mkExistential env isevars in ev, ev - | Some t -> - t, prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars) - tomatchs sign (lift tomatchs_len t) - in - let neqs, arity = - let ctx = context_of_arsign eqs in - let neqs = List.length ctx in - neqs, it_mkProd_or_LetIn (lift neqs arity) ctx - in - let lets, matx = - (* Type the rhs under the assumption of equations *) - constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity - in - let matx = List.rev matx in - let _ = assert(len = List.length lets) in - let env = push_rels lets env in - let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in - let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in - let args = List.rev_map (lift len) args in - let pred = liftn len (succ signlen) arity in - let pred = build_initial_predicate true allnames pred in - - (* We push the initial terms to match and push their alias to rhs' envs *) - (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in - - let pb = - { env = env; - isevars = isevars; - pred = Some pred; - tomatch = initial_pushed; - history = start_history (List.length initial_pushed); - mat = matx; - caseloc = loc; - casestyle= style; - typing_function = typing_fun } in - - let j = compile pb in - (* We check for unused patterns *) - List.iter (check_unused_pattern env) matx; - let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in - let j = - { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; - uj_type = nf_isevar !isevars tycon; } - in j - else - (* We build the elimination predicate if any and check its consistency *) - (* with the type of arguments to match *) - let tmsign = List.map snd tomatchl in - let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in - - (* We push the initial terms to match and push their alias to rhs' envs *) - (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in - let pb = - { env = env; - isevars = isevars; - pred = pred; - tomatch = initial_pushed; - history = start_history (List.length initial_pushed); - mat = matx; - caseloc = loc; - casestyle= style; - typing_function = typing_fun } in - - let j = compile pb in - (* We check for unused patterns *) - List.iter (check_unused_pattern env) matx; - inh_conv_coerce_to_tycon loc env isevars j tycon - -end - diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli deleted file mode 100644 index 6b8a0981..00000000 --- a/contrib/subtac/subtac_cases.mli +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*) - -(*i*) -open Util -open Names -open Term -open Evd -open Environ -open Inductiveops -open Rawterm -open Evarutil -(*i*) - -(*s Compilation of pattern-matching, subtac style. *) -module Cases_F(C : Coercion.S) : Cases.S diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml deleted file mode 100644 index 9b692d85..00000000 --- a/contrib/subtac/subtac_classes.ml +++ /dev/null @@ -1,194 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: subtac_classes.ml 12187 2009-06-13 19:36:59Z msozeau $ i*) - -open Pretyping -open Evd -open Environ -open Term -open Rawterm -open Topconstr -open Names -open Libnames -open Pp -open Vernacexpr -open Constrintern -open Subtac_command -open Typeclasses -open Typeclasses_errors -open Termops -open Decl_kinds -open Entries -open Util - -module SPretyping = Subtac_pretyping.Pretyping - -let interp_binder_evars evdref env na t = - let t = Constrintern.intern_gen true (Evd.evars_of !evdref) env t in - SPretyping.understand_tcc_evars evdref env IsType t - -let interp_binders_evars isevars env avoid l = - List.fold_left - (fun (env, ids, params) ((loc, i), t) -> - let n = Name i in - let t' = interp_binder_evars isevars env n t in - let d = (i,None,t') in - (push_named d env, i :: ids, d::params)) - (env, avoid, []) l - -let interp_typeclass_context_evars isevars env avoid l = - List.fold_left - (fun (env, ids, params) (iid, bk, cl) -> - let t' = interp_binder_evars isevars env (snd iid) cl in - let i = match snd iid with - | Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids - | Name id -> id - in - let d = (i,None,t') in - (push_named d env, i :: ids, d::params)) - (env, avoid, []) l - -let interp_constrs_evars isevars env avoid l = - List.fold_left - (fun (env, ids, params) t -> - let t' = interp_binder_evars isevars env Anonymous t in - let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in - let d = (id,None,t') in - (push_named d env, id :: ids, d::params)) - (env, avoid, []) l - -let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c = - SPretyping.understand_tcc_evars evdref env kind - (intern_gen (kind=IsType) ~impls (Evd.evars_of !evdref) env c) - -let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ = - interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c - -let type_ctx_instance isevars env ctx inst subst = - List.fold_left2 - (fun (subst, instctx) (na, _, t) ce -> - let t' = substl subst t in - let c = interp_casted_constr_evars isevars env ce t' in - isevars := resolve_typeclasses ~onlyargs:true ~fail:true env !isevars; - let d = na, Some c, t' in - c :: subst, d :: instctx) - (subst, []) (List.rev ctx) inst - -let type_class_instance_params isevars env id n ctx inst subst = - List.fold_left2 - (fun (subst, instctx) (na, _, t) ce -> - let t' = replace_vars subst t in - let c = interp_casted_constr_evars isevars env ce t' in - let d = na, Some c, t' in - (na, c) :: subst, d :: instctx) - (subst, []) (List.rev ctx) inst - -let substitution_of_constrs ctx cstrs = - List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx [] - -let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri = - let env = Global.env() in - let isevars = ref (Evd.create_evar_defs Evd.empty) in - let tclass = - match bk with - | Implicit -> - Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) - ~allow_partial:false (fun avoid (clname, (id, _, t)) -> - match clname with - | Some (cl, b) -> - let t = - if b then - let _k = class_info cl in - CHole (Util.dummy_loc, Some Evd.InternalHole) - else CHole (Util.dummy_loc, None) - in t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - cl - | Explicit -> cl - in - let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in - let k, ctx', imps, subst = - let c = Command.generalize_constr_expr tclass ctx in - let c', imps = interp_type_evars_impls ~evdref:isevars env c in - let ctx, c = Sign.decompose_prod_assum c' in - let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in - cl, ctx, imps, (List.rev args) - in - let id = - match snd instid with - | Name id -> - let sp = Lib.make_path id in - if Nametab.exists_cci sp then - errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); - id - | Anonymous -> - let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in - Termops.next_global_ident_away false i (Termops.ids_of_context env) - in - let env' = push_rel_context ctx' env in - isevars := Evarutil.nf_evar_defs !isevars; - isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; - let sigma = Evd.evars_of !isevars in - let subst = List.map (Evarutil.nf_evar sigma) subst in - let subst = - let props = - match props with - | CRecord (loc, _, fs) -> - if List.length fs > List.length k.cl_props then - Classes.mismatched_props env' (List.map snd fs) k.cl_props; - fs - | _ -> - if List.length k.cl_props <> 1 then - errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") - else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] - in - match k.cl_props with - | [(na,b,ty)] -> - let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in - let ty' = substl subst ty in - let c = interp_casted_constr_evars isevars env' term ty' in - c :: subst - | _ -> - let props, rest = - List.fold_left - (fun (props, rest) (id,_,_) -> - try - let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in - let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); - c :: props, rest' - with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) - ([], props) k.cl_props - in - if rest <> [] then - unbound_method env' k.cl_impl (fst (List.hd rest)) - else - fst (type_ctx_instance isevars env' k.cl_props props subst) - in - let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') - [] subst (k.cl_props @ snd k.cl_context) - in - let inst_constr, ty_constr = instance_constructor k subst in - isevars := Evarutil.nf_evar_defs !isevars; - let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') - and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') - in - isevars := undefined_evars !isevars; - Evarutil.check_evars env Evd.empty !isevars termtype; - let hook vis gr = - let cst = match gr with ConstRef kn -> kn | _ -> assert false in - let inst = Typeclasses.new_instance k pri global cst in - Impargs.declare_manual_implicits false gr ~enriching:false imps; - Typeclasses.add_instance inst - in - let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in - let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in - id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls - diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli deleted file mode 100644 index 96a51027..00000000 --- a/contrib/subtac/subtac_classes.mli +++ /dev/null @@ -1,42 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i $Id: subtac_classes.mli 11709 2008-12-20 11:42:15Z msozeau $ i*) - -(*i*) -open Names -open Decl_kinds -open Term -open Sign -open Evd -open Environ -open Nametab -open Mod_subst -open Topconstr -open Util -open Typeclasses -open Implicit_quantifiers -open Classes -(*i*) - -val type_ctx_instance : Evd.evar_defs ref -> - Environ.env -> - ('a * Term.constr option * Term.constr) list -> - Topconstr.constr_expr list -> - Term.constr list -> - Term.constr list * - ('a * Term.constr option * Term.constr) list - -val new_instance : - ?global:bool -> - local_binder list -> - typeclass_constraint -> - constr_expr -> - ?generalize:bool -> - int option -> - identifier * Subtac_obligations.progress diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml deleted file mode 100644 index 1bbbfbb1..00000000 --- a/contrib/subtac/subtac_coercion.ml +++ /dev/null @@ -1,504 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* $Id: subtac_coercion.ml 11576 2008-11-10 19:13:15Z msozeau $ *) - -open Util -open Names -open Term -open Reductionops -open Environ -open Typeops -open Pretype_errors -open Classops -open Recordops -open Evarutil -open Evarconv -open Retyping -open Evd - -open Global -open Subtac_utils -open Coqlib -open Printer -open Subtac_errors -open Eterm -open Pp - -let pair_of_array a = (a.(0), a.(1)) -let make_name s = Name (id_of_string s) - -let rec disc_subset x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Ind i -> - let len = Array.length l in - let sig_ = Lazy.force sig_ in - if len = 2 && i = Term.destInd sig_.typ - then - let (a, b) = pair_of_array l in - Some (a, b) - else None - | _ -> None) - | _ -> None - -and disc_exist env x = - match kind_of_term x with - | App (c, l) -> - (match kind_of_term c with - Construct c -> - if c = Term.destConstruct (Lazy.force sig_).intro - then Some (l.(0), l.(1), l.(2), l.(3)) - else None - | _ -> None) - | _ -> None - -module Coercion = struct - - exception NoSubtacCoercion - - let disc_proj_exist env x = - match kind_of_term x with - | App (c, l) -> - (if Term.eq_constr c (Lazy.force sig_).proj1 - && Array.length l = 3 - then disc_exist env l.(2) - else None) - | _ -> None - - - let sort_rel s1 s2 = - match s1, s2 with - Prop Pos, Prop Pos -> Prop Pos - | Prop Pos, Prop Null -> Prop Null - | Prop Null, Prop Null -> Prop Null - | Prop Null, Prop Pos -> Prop Pos - | Type _, Prop Pos -> Prop Pos - | Type _, Prop Null -> Prop Null - | _, Type _ -> s2 - - let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c - - let lift_args n sign = - let rec liftrec k = function - | t::sign -> liftn n k t :: (liftrec (k-1) sign) - | [] -> [] - in - liftrec (List.length sign) sign - - let rec mu env isevars t = - let isevars = ref isevars in - let rec aux v = - let v = hnf env isevars v in - match disc_subset v with - Some (u, p) -> - let f, ct = aux u in - (Some (fun x -> - app_opt f (mkApp ((Lazy.force sig_).proj1, - [| u; p; x |]))), - ct) - | None -> (None, v) - in aux t - - and coerce loc env isevars (x : Term.constr) (y : Term.constr) - : (Term.constr -> Term.constr) option - = - let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in - let rec coerce_unify env x y = - let x = hnf env isevars x and y = hnf env isevars y in - try - isevars := the_conv_x_leq env x y !isevars; - None - with Reduction.NotConvertible -> coerce' env x y - and coerce' env x y : (Term.constr -> Term.constr) option = - let subco () = subset_coerce env isevars x y in - let dest_prod c = - match Reductionops.decomp_n_prod env (evars_of !isevars) 1 c with - | [(na,b,t)], c -> (na,t), c - | _ -> raise NoSubtacCoercion - in - let rec coerce_application typ typ' c c' l l' = - let len = Array.length l in - let rec aux tele typ typ' i co = - if i < len then - let hdx = l.(i) and hdy = l'.(i) in - try isevars := the_conv_x_leq env hdx hdy !isevars; - let (n, eqT), restT = dest_prod typ in - let (n', eqT'), restT' = dest_prod typ' in - aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co - with Reduction.NotConvertible -> - let (n, eqT), restT = dest_prod typ in - let (n', eqT'), restT' = dest_prod typ' in - let _ = - try isevars := the_conv_x_leq env eqT eqT' !isevars - with Reduction.NotConvertible -> raise NoSubtacCoercion - in - (* Disallow equalities on arities *) - if Reduction.is_arity env eqT then raise NoSubtacCoercion; - let restargs = lift_args 1 - (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) - in - let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in - let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in - let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in - let evar = make_existential loc env isevars eq in - let eq_app x = mkApp (Lazy.force eq_rect, - [| eqT; hdx; pred; x; hdy; evar|]) in - aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) - else Some co - in - if isEvar c || isEvar c' then - (* Second-order unification needed. *) - raise NoSubtacCoercion; - aux [] typ typ' 0 (fun x -> x) - in - match (kind_of_term x, kind_of_term y) with - | Sort s, Sort s' -> - (match s, s' with - Prop x, Prop y when x = y -> None - | Prop _, Type _ -> None - | Type x, Type y when x = y -> None (* false *) - | _ -> subco ()) - | Prod (name, a, b), Prod (name', a', b') -> - let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in - let env' = push_rel (name', None, a') env in - let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in - (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) - let coec1 = app_opt c1 (mkRel 1) in - (* env, x : a' |- c1[x] : lift 1 a *) - let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in - (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) - (match c1, c2 with - None, None -> failwith "subtac.coerce': Should have detected equivalence earlier" - | _, _ -> - Some - (fun f -> - mkLambda (name', a', - app_opt c2 - (mkApp (Term.lift 1 f, [| coec1 |]))))) - - | App (c, l), App (c', l') -> - (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Inductive types *) - let len = Array.length l in - let existS = Lazy.force existS in - let prod = Lazy.force prod in - (* Sigma types *) - if len = Array.length l' && len = 2 && i = i' - && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) - then - if i = Term.destInd existS.typ - then - begin - let (a, pb), (a', pb') = - pair_of_array l, pair_of_array l' - in - let c1 = coerce_unify env a a' in - let rec remove_head a c = - match kind_of_term c with - | Lambda (n, t, t') -> c, t' - (*| Prod (n, t, t') -> t'*) - | Evar (k, args) -> - let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in - isevars := evs; - let (n, dom, rng) = destLambda t in - let (domk, args) = destEvar dom in - isevars := evar_define domk a !isevars; - t, rng - | _ -> raise NoSubtacCoercion - in - let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (make_name "x", None, a) env in - let c2 = coerce_unify env' b b' in - match c1, c2 with - None, None -> - None - | _, _ -> - Some - (fun x -> - let x, y = - app_opt c1 (mkApp (existS.proj1, - [| a; pb; x |])), - app_opt c2 (mkApp (existS.proj2, - [| a; pb; x |])) - in - mkApp (existS.intro, [| a'; pb'; x ; y |])) - end - else - begin - let (a, b), (a', b') = - pair_of_array l, pair_of_array l' - in - let c1 = coerce_unify env a a' in - let c2 = coerce_unify env b b' in - match c1, c2 with - None, None -> None - | _, _ -> - Some - (fun x -> - let x, y = - app_opt c1 (mkApp (prod.proj1, - [| a; b; x |])), - app_opt c2 (mkApp (prod.proj2, - [| a; b; x |])) - in - mkApp (prod.intro, [| a'; b'; x ; y |])) - end - else - if i = i' && len = Array.length l' then - let evm = evars_of !isevars in - (try subco () - with NoSubtacCoercion -> - let typ = Typing.type_of env evm c in - let typ' = Typing.type_of env evm c' in - (* if not (is_arity env evm typ) then *) - coerce_application typ typ' c c' l l') - (* else subco () *) - else - subco () - | x, y when x = y -> - if Array.length l = Array.length l' then - let evm = evars_of !isevars in - let lam_type = Typing.type_of env evm c in - let lam_type' = Typing.type_of env evm c' in -(* if not (is_arity env evm lam_type) then ( *) - coerce_application lam_type lam_type' c c' l l' -(* ) else subco () *) - else subco () - | _ -> subco ()) - | _, _ -> subco () - - and subset_coerce env isevars x y = - match disc_subset x with - Some (u, p) -> - let c = coerce_unify env u y in - let f x = - app_opt c (mkApp ((Lazy.force sig_).proj1, - [| u; p; x |])) - in Some f - | None -> - match disc_subset y with - Some (u, p) -> - let c = coerce_unify env x u in - Some - (fun x -> - let cx = app_opt c x in - let evar = make_existential loc env isevars (mkApp (p, [| cx |])) - in - (mkApp - ((Lazy.force sig_).intro, - [| u; p; cx; evar |]))) - | None -> - raise NoSubtacCoercion - (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars; - None*) - in coerce_unify env x y - - let coerce_itf loc env isevars v t c1 = - let evars = ref isevars in - let coercion = coerce loc env evars t c1 in - !evars, Option.map (app_opt coercion) v - - (* Taken from pretyping/coercion.ml *) - - (* Typing operations dealing with coercions *) - - (* Here, funj is a coercion therefore already typed in global context *) - let apply_coercion_args env argl funj = - let rec apply_rec acc typ = function - | [] -> { uj_val = applist (j_val funj,argl); - uj_type = typ } - | h::restl -> - (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) - match kind_of_term (whd_betadeltaiota env Evd.empty typ) with - | Prod (_,c1,c2) -> - (* Typage garanti par l'appel à app_coercion*) - apply_rec (h::acc) (subst1 h c2) restl - | _ -> anomaly "apply_coercion_args" - in - apply_rec [] funj.uj_type argl - - (* appliquer le chemin de coercions de patterns p *) - exception NoCoercion - - let apply_pattern_coercion loc pat p = - List.fold_left - (fun pat (co,n) -> - let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in - Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous)) - pat p - - (* raise Not_found if no coercion found *) - let inh_pattern_coerce_to loc pat ind1 ind2 = - let p = lookup_pattern_path_between (ind1,ind2) in - apply_pattern_coercion loc pat p - - (* appliquer le chemin de coercions p à hj *) - - let apply_coercion env sigma p hj typ_cl = - try - fst (List.fold_left - (fun (ja,typ_cl) i -> - let fv,isid = coercion_value i in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let jres = apply_coercion_args env argl fv in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type) - (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" - - let inh_app_fun env isevars j = - let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in - match kind_of_term t with - | Prod (_,_,_) -> (isevars,j) - | Evar ev when not (is_defined_evar isevars ev) -> - let (isevars',t) = define_evar_as_product isevars ev in - (isevars',{ uj_val = j.uj_val; uj_type = t }) - | _ -> - (try - let t,p = - lookup_path_to_fun_from env (evars_of isevars) j.uj_type in - (isevars,apply_coercion env (evars_of isevars) p j t) - with Not_found -> - try - let coercef, t = mu env isevars t in - (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) - with NoSubtacCoercion | NoCoercion -> - (isevars,j)) - - let inh_tosort_force loc env isevars j = - try - let t,p = lookup_path_to_sort_from env (evars_of isevars) j.uj_type in - let j1 = apply_coercion env (evars_of isevars) p j t in - (isevars,type_judgment env (j_nf_evar (evars_of isevars) j1)) - with Not_found -> - error_not_a_type_loc loc env (evars_of isevars) j - - let inh_coerce_to_sort loc env isevars j = - let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in - match kind_of_term typ with - | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s }) - | Evar ev when not (is_defined_evar isevars ev) -> - let (isevars',s) = define_evar_as_sort isevars ev in - (isevars',{ utj_val = j.uj_val; utj_type = s }) - | _ -> - inh_tosort_force loc env isevars j - - let inh_coerce_to_base loc env isevars j = - let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in - let ct, typ' = mu env isevars typ in - isevars, { uj_val = app_opt ct j.uj_val; - uj_type = typ' } - - let inh_coerce_to_prod loc env isevars t = - let typ = whd_betadeltaiota env (evars_of isevars) (snd t) in - let _, typ' = mu env isevars typ in - isevars, (fst t, typ') - - let inh_coerce_to_fail env evd rigidonly v t c1 = - if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) - then - raise NoCoercion - else - let v', t' = - try - let t2,t1,p = lookup_path_between env (evars_of evd) (t,c1) in - match v with - Some v -> - let j = apply_coercion env (evars_of evd) p - {uj_val = v; uj_type = t} t2 in - Some j.uj_val, j.uj_type - | None -> None, t - with Not_found -> raise NoCoercion - in - try (the_conv_x_leq env t' c1 evd, v') - with Reduction.NotConvertible -> raise NoCoercion - - - let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = - try (the_conv_x_leq env t c1 evd, v) - with Reduction.NotConvertible -> - try inh_coerce_to_fail env evd rigidonly v t c1 - with NoCoercion -> - match - kind_of_term (whd_betadeltaiota env (evars_of evd) t), - kind_of_term (whd_betadeltaiota env (evars_of evd) c1) - with - | Prod (name,t1,t2), Prod (_,u1,u2) -> - (* Conversion did not work, we may succeed with a coercion. *) - (* We eta-expand (hence possibly modifying the original term!) *) - (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) - (* has type forall (x:u1), u2 (with v' recursively obtained) *) - let name = match name with - | Anonymous -> Name (id_of_string "x") - | _ -> name in - let env1 = push_rel (name,None,u1) env in - let (evd', v1) = - inh_conv_coerce_to_fail loc env1 evd rigidonly - (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in - let v1 = Option.get v1 in - let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in - let t2 = Termops.subst_term v1 t2 in - let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in - (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') - | _ -> raise NoCoercion - - (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) - let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = - let evd = nf_evar_defs evd in - match n with - None -> - let (evd', val') = - try - inh_conv_coerce_to_fail loc env evd rigidonly - (Some (nf_isevar evd cj.uj_val)) - (nf_isevar evd cj.uj_type) (nf_isevar evd t) - with NoCoercion -> - let sigma = evars_of evd in - try - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t - with NoSubtacCoercion -> - error_actual_type_loc loc env sigma cj t - in - let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = val'; uj_type = t }) - | Some (init, cur) -> - (evd, cj) - - let inh_conv_coerce_to = inh_conv_coerce_to_gen false - let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true - - let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) = - let nabsinit, nabs = - match abs with - None -> 0, 0 - | Some (init, cur) -> init, cur - in - try - let rels, rng = Reductionops.decomp_n_prod env (evars_of isevars) nabs t in - (* The final range free variables must have been replaced by evars, we accept only that evars - in rng are applied to free vars. *) - if noccur_with_meta 1 (succ nabs) rng then ( - let env', t, t' = - let env' = push_rel_context rels env in - env', rng, lift nabs t' - in - try - fst (try inh_conv_coerce_to_fail loc env' isevars false None t t' - with NoCoercion -> - coerce_itf loc env' isevars None t t') - with NoSubtacCoercion -> - let sigma = evars_of isevars in - error_cannot_coerce env' sigma (t, t')) - else isevars - with _ -> isevars -end diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli deleted file mode 100644 index 5678c10e..00000000 --- a/contrib/subtac/subtac_coercion.mli +++ /dev/null @@ -1,4 +0,0 @@ -open Term -val disc_subset : types -> (types * types) option - -module Coercion : Coercion.S diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml deleted file mode 100644 index c8c7ff72..00000000 --- a/contrib/subtac/subtac_command.ml +++ /dev/null @@ -1,466 +0,0 @@ -open Closure -open RedFlags -open Declarations -open Entries -open Dyn -open Libobject -open Pattern -open Matching -open Pp -open Rawterm -open Sign -open Tacred -open Util -open Names -open Nameops -open Libnames -open Nametab -open Pfedit -open Proof_type -open Refiner -open Tacmach -open Tactic_debug -open Topconstr -open Term -open Termops -open Tacexpr -open Safe_typing -open Typing -open Hiddentac -open Genarg -open Decl_kinds -open Mod_subst -open Printer -open Inductiveops -open Syntax_def -open Environ -open Tactics -open Tacticals -open Tacinterp -open Vernacexpr -open Notation -open Evd -open Evarutil - -module SPretyping = Subtac_pretyping.Pretyping -open Subtac_utils -open Pretyping -open Subtac_obligations - -(*********************************************************************) -(* Functions to parse and interpret constructions *) - -let evar_nf isevars c = - isevars := Evarutil.nf_evar_defs !isevars; - Evarutil.nf_isevar !isevars c - -let interp_gen kind isevars env - ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) - c = - let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars (Evd.evars_of !isevars) env c in - let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in - evar_nf isevars c' - -let interp_constr isevars env c = - interp_gen (OfType None) isevars env c - -let interp_type_evars isevars env ?(impls=([],[])) c = - interp_gen IsType isevars env ~impls c - -let interp_casted_constr isevars env ?(impls=([],[])) c typ = - interp_gen (OfType (Some typ)) isevars env ~impls c - -let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ = - interp_gen (OfType (Some typ)) isevars env ~impls c - -let interp_open_constr isevars env c = - msgnl (str "Pretyping " ++ my_print_constr_expr c); - let c = Constrintern.intern_constr (Evd.evars_of !isevars) env c in - let c' = SPretyping.pretype_gen isevars env ([], []) (OfType None) c in - evar_nf isevars c' - -let interp_constr_judgment isevars env c = - let j = - SPretyping.understand_judgment_tcc isevars env - (Constrintern.intern_constr (Evd.evars_of !isevars) env c) - in - { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } - -let locate_if_isevar loc na = function - | RHole _ -> - (try match na with - | Name id -> Reserve.find_reserved_type id - | Anonymous -> raise Not_found - with Not_found -> RHole (loc, Evd.BinderType na)) - | x -> x - -let interp_binder sigma env na t = - let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in - SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t) - -let interp_context_evars evdref env params = - let bl = Constrintern.intern_context false (Evd.evars_of !evdref) env params in - let (env, par, _, impls) = - List.fold_left - (fun (env,params,n,impls) (na, k, b, t) -> - match b with - None -> - let t' = locate_if_isevar (loc_of_rawconstr t) na t in - let t = SPretyping.understand_tcc_evars evdref env IsType t' in - let d = (na,None,t) in - let impls = - if k = Implicit then - let na = match na with Name n -> Some n | Anonymous -> None in - (ExplByPos (n, na), (true, true)) :: impls - else impls - in - (push_rel d env, d::params, succ n, impls) - | Some b -> - let c = SPretyping.understand_judgment_tcc evdref env b in - let d = (na, Some c.uj_val, c.uj_type) in - (push_rel d env,d::params, succ n, impls)) - (env,[],1,[]) (List.rev bl) - in (env, par), impls - -(* try to find non recursive definitions *) - -let list_chop_hd i l = match list_chop i l with - | (l1,x::l2) -> (l1,x,l2) - | (x :: [], l2) -> ([], x, []) - | _ -> assert(false) - -let collect_non_rec env = - let rec searchrec lnonrec lnamerec ldefrec larrec nrec = - try - let i = - list_try_find_i - (fun i f -> - if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec - then i else failwith "try_find_i") - 0 lnamerec - in - let (lf1,f,lf2) = list_chop_hd i lnamerec in - let (ldef1,def,ldef2) = list_chop_hd i ldefrec in - let (lar1,ar,lar2) = list_chop_hd i larrec in - let newlnv = - try - match list_chop i nrec with - | (lnv1,_::lnv2) -> (lnv1@lnv2) - | _ -> [] (* nrec=[] for cofixpoints *) - with Failure "list_chop" -> [] - in - searchrec ((f,def,ar)::lnonrec) - (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv - with Failure "try_find_i" -> - (List.rev lnonrec, - (Array.of_list lnamerec, Array.of_list ldefrec, - Array.of_list larrec, Array.of_list nrec)) - in - searchrec [] - -let list_of_local_binders l = - let rec aux acc = function - Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl - | Topconstr.LocalRawAssum (nl, k, c) :: tl -> - aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl - | [] -> List.rev acc - in aux [] l - -let lift_binders k n l = - let rec aux n = function - | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl - | [] -> [] - in aux n l - -let rec gen_rels = function - 0 -> [] - | n -> mkRel n :: gen_rels (pred n) - -let split_args n rel = match list_chop ((List.length rel) - n) rel with - (l1, x :: l2) -> l1, x, l2 - | _ -> assert(false) - -let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = - Coqlib.check_required_library ["Coq";"Program";"Wf"]; - let sigma = Evd.empty in - let isevars = ref (Evd.create_evar_defs sigma) in - let env = Global.env() in - let pr c = my_print_constr env c in - let prr = Printer.pr_rel_context env in - let _prn = Printer.pr_named_context env in - let _pr_rel env = Printer.pr_rel_context env in -(* let _ = *) -(* try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ *) -(* Ppconstr.pr_binders bl ++ str " : " ++ *) -(* Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ *) -(* Ppconstr.pr_constr_expr body) *) -(* with _ -> () *) - (* in *) - let (env', binders_rel), impls = interp_context_evars isevars env bl in - let after, ((argname, _, argtyp) as arg), before = - let idx = list_index (Name (snd n)) (List.rev_map (fun (na, _, _) -> na) binders_rel) in - split_args idx binders_rel in - let before_length, after_length = List.length before, List.length after in - let argid = match argname with Name n -> n | _ -> assert(false) in - let liftafter = lift_binders 1 after_length after in - let envwf = push_rel_context before env in - let wf_rel, wf_rel_fun, measure_fn = - let rconstr_body, rconstr = - let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in - let env = push_rel_context [arg] envwf in - let capp = interp_constr isevars env app in - capp, mkLambda (argname, argtyp, capp) - in - trace (str"rconstr_body: " ++ pr rconstr_body); - if measure then - let lt_rel = constr_of_global (Lazy.force lt_ref) in - let name s = Name (id_of_string s) in - let wf_rel_fun lift x y = (* lift to before_env *) - trace (str"lifter rconstr_body:" ++ pr (liftn lift 2 rconstr_body)); - mkApp (lt_rel, [| subst1 x (liftn lift 2 rconstr_body); - subst1 y (liftn lift 2 rconstr_body) |]) - in - let wf_rel = - mkLambda (name "x", argtyp, - mkLambda (name "y", lift 1 argtyp, - wf_rel_fun 0 (mkRel 2) (mkRel 1))) - in - wf_rel, wf_rel_fun , Some rconstr - else rconstr, (fun lift x y -> mkApp (rconstr, [|x; y|])), None - in - let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) - in - let argid' = id_of_string (string_of_id argid ^ "'") in - let wfarg len = (Name argid', None, - mkSubset (Name argid') (lift len argtyp) - (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1)))) - in - let top_bl = after @ (arg :: before) in - let top_env = push_rel_context top_bl env in - let top_arity = interp_type_evars isevars top_env arityc in - let intern_bl = wfarg 1 :: arg :: before in - let _intern_env = push_rel_context intern_bl env in - let proj = (Lazy.force sig_).Coqlib.proj1 in - let projection = - mkApp (proj, [| argtyp ; - (mkLambda (Name argid', argtyp, - (wf_rel_fun 1 (mkRel 1) (mkRel 3)))) ; - mkRel 1 - |]) - in - let intern_arity = it_mkProd_or_LetIn top_arity after in - (* Intern arity is in top_env = arg :: before *) - let intern_arity = liftn 2 2 intern_arity in -(* trace (str "After lifting arity: " ++ *) -(* my_print_constr (push_rel (Name argid', None, lift 2 argtyp) intern_env) *) -(* intern_arity); *) - (* arity is now in something :: wfarg :: arg :: before - where what refered to arg now refers to something *) - let intern_arity = substl [projection] intern_arity in - (* substitute the projection of wfarg for something *) - let intern_before_env = push_rel_context before env in - let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in - let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in - let fun_env = push_rel_context fun_bl intern_before_env in - let fun_arity = interp_type_evars isevars fun_env arityc in - let intern_body = interp_casted_constr isevars fun_env body fun_arity in - let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in - let _ = - try trace ((* str "Fun bl: " ++ prr fun_bl ++ spc () ++ *) - str "Intern bl" ++ prr intern_bl ++ spc ()) -(* str "Top bl" ++ prr top_bl ++ spc () ++ *) -(* str "Intern arity: " ++ pr intern_arity ++ *) -(* str "Top arity: " ++ pr top_arity ++ spc () ++ *) -(* str "Intern body " ++ pr intern_body_lam) *) - with _ -> () - in - let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in - (* Lift to get to constant arguments *) - let lift_cst = List.length after + 1 in - let fix_def = - match measure_fn with - None -> - mkApp (constr_of_global (Lazy.force fix_sub_ref), - [| argtyp ; - wf_rel ; - make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; - lift lift_cst prop ; - lift lift_cst intern_body_lam |]) - | Some f -> - mkApp (constr_of_global (Lazy.force fix_measure_sub_ref), - [| lift lift_cst argtyp ; - lift lift_cst f ; - lift lift_cst prop ; - lift lift_cst intern_body_lam |]) - in - let def_appl = applist (fix_def, gen_rels (after_length + 1)) in - let def = it_mkLambda_or_LetIn def_appl binders_rel in - let typ = it_mkProd_or_LetIn top_arity binders_rel in - let fullcoqc = Evarutil.nf_isevar !isevars def in - let fullctyp = Evarutil.nf_isevar !isevars typ in - let evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in - let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in - let evm = non_instanciated_map env isevars evm in - let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in - Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars - -let nf_evar_context isevars ctx = - List.map (fun (n, b, t) -> - (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx - -let interp_fix_context evdref env fix = - interp_context_evars evdref env fix.Command.fix_binders - -let interp_fix_ccl evdref (env,_) fix = - interp_type_evars evdref env fix.Command.fix_type - -let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = - let env = push_rel_context ctx env_rec in - let body = interp_casted_constr_evars evdref env ~impls fix.Command.fix_body ccl in - it_mkLambda_or_LetIn body ctx - -let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx - -let prepare_recursive_declaration fixnames fixtypes fixdefs = - let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map (fun id -> Name id) fixnames in - (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) - -let rel_index n ctx = - list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) - -let rec unfold f b = - match f b with - | Some (x, b') -> x :: unfold f b' - | None -> [] - -let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with - | Some (loc, n) -> [rel_index n fixctx] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - let len = List.length fixctx in - unfold (function x when x = len -> None - | n -> Some (n, succ n)) 0 - -let push_named_context = List.fold_right push_named - -let check_evars env initial_sigma evd c = - let sigma = evars_of evd in - let c = nf_evar sigma c in - let rec proc_rec c = - match kind_of_term c with - | Evar (evk,args) -> - assert (Evd.mem sigma evk); - if not (Evd.mem initial_sigma evk) then - let (loc,k) = evar_source evk evd in - (match k with - | QuestionMark _ -> () - | _ -> - let evi = nf_evar_info sigma (Evd.find sigma evk) in - Pretype_errors.error_unsolvable_implicit loc env sigma evi k None) - | _ -> iter_constr proc_rec c - in proc_rec c - -let interp_recursive fixkind l boxed = - let env = Global.env() in - let fixl, ntnl = List.split l in - let kind = if fixkind <> Command.IsCoFixpoint then Fixpoint else CoFixpoint in - let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in - - (* Interp arities allowing for unresolved types *) - let evdref = ref (Evd.create_evar_defs Evd.empty) in - let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in - let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in - let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let rec_sign = - List.fold_left2 (fun env id t -> (id,None,t) :: env) - [] fixnames fixtypes - in - let env_rec = push_named_context rec_sign env in - - (* Get interpretation metadatas *) - let impls = Command.compute_interning_datas env Constrintern.Recursive [] fixnames fixtypes fiximps in - let notations = List.fold_right Option.List.cons ntnl [] in - - (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - States.with_state_protection (fun () -> - List.iter (Command.declare_interning_data impls) notations; - list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) - () in - - (* Instantiate evars and check all are resolved *) - let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in - let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in - let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in - let rec_sign = nf_named_context_evar (evars_of evd) rec_sign in - - let recdefs = List.length rec_sign in - List.iter (check_evars env_rec Evd.empty evd) fixdefs; - List.iter (check_evars env Evd.empty evd) fixtypes; - Command.check_mutuality env kind (List.combine fixnames fixdefs); - - (* Russell-specific code *) - - (* Get the interesting evars, those that were not instanciated *) - let isevars = Evd.undefined_evars evd in - let evm = Evd.evars_of isevars in - (* Solve remaining evars *) - let rec collect_evars id def typ imps = - (* Generalize by the recursive prototypes *) - let def = - Termops.it_mkNamedLambda_or_LetIn def rec_sign - and typ = - Termops.it_mkNamedProd_or_LetIn typ rec_sign - in - let evm' = Subtac_utils.evars_of_term evm Evd.empty def in - let evm' = Subtac_utils.evars_of_term evm evm' typ in - let evars, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in - (id, def, typ, imps, evars) - in - let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in - (match fixkind with - | Command.IsFixpoint wfl -> - let possible_indexes = - list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), - Array.of_list fixtypes, - Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) - in - let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in - list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l - | Command.IsCoFixpoint -> ()); - Subtac_obligations.add_mutual_definitions defs notations fixkind - -let out_n = function - Some n -> n - | None -> raise Not_found - -let build_recursive l b = - let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in - match g, l with - [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> - ignore(build_wellfounded (id, out_n n, bl, typ, def) r false ntn false) - - | [(n, CMeasureRec r)], [(((_,id),_,bl,typ,def),ntn)] -> - ignore(build_wellfounded (id, out_n n, bl, typ, def) r true ntn false) - - | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> - let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l - in interp_recursive (Command.IsFixpoint g) fixl b - | _, _ -> - errorlabstrm "Subtac_command.build_recursive" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") - -let build_corecursive l b = - let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) - l in - interp_recursive Command.IsCoFixpoint fixl b diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli deleted file mode 100644 index 3a6a351b..00000000 --- a/contrib/subtac/subtac_command.mli +++ /dev/null @@ -1,50 +0,0 @@ -open Pretyping -open Evd -open Environ -open Term -open Topconstr -open Names -open Libnames -open Pp -open Vernacexpr -open Constrintern - -val interp_gen : - typing_constraint -> - evar_defs ref -> - env -> - ?impls:full_implicits_env -> - ?allow_patvar:bool -> - ?ltacvars:ltac_sign -> - constr_expr -> constr -val interp_constr : - evar_defs ref -> - env -> constr_expr -> constr -val interp_type_evars : - evar_defs ref -> - env -> - ?impls:full_implicits_env -> - constr_expr -> constr -val interp_casted_constr_evars : - evar_defs ref -> - env -> - ?impls:full_implicits_env -> - constr_expr -> types -> constr -val interp_open_constr : - evar_defs ref -> env -> constr_expr -> constr -val interp_constr_judgment : - evar_defs ref -> - env -> - constr_expr -> unsafe_judgment -val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list - -val interp_binder : Evd.evar_defs ref -> - Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr - - - -val build_recursive : - (fixpoint_expr * decl_notation) list -> bool -> unit - -val build_corecursive : - (cofixpoint_expr * decl_notation) list -> bool -> unit diff --git a/contrib/subtac/subtac_errors.ml b/contrib/subtac/subtac_errors.ml deleted file mode 100644 index 3bbfe22b..00000000 --- a/contrib/subtac/subtac_errors.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Util -open Pp -open Printer - -type term_pp = Pp.std_ppcmds - -type subtyping_error = - | UncoercibleInferType of loc * term_pp * term_pp - | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp - | UncoercibleRewrite of term_pp * term_pp - -type typing_error = - | NonFunctionalApp of loc * term_pp * term_pp * term_pp - | NonConvertible of loc * term_pp * term_pp - | NonSigma of loc * term_pp - | IllSorted of loc * term_pp - -exception Subtyping_error of subtyping_error -exception Typing_error of typing_error - -exception Debug_msg of string - -let typing_error e = raise (Typing_error e) -let subtyping_error e = raise (Subtyping_error e) diff --git a/contrib/subtac/subtac_errors.mli b/contrib/subtac/subtac_errors.mli deleted file mode 100644 index 8d75b9c0..00000000 --- a/contrib/subtac/subtac_errors.mli +++ /dev/null @@ -1,15 +0,0 @@ -type term_pp = Pp.std_ppcmds -type subtyping_error = - UncoercibleInferType of Util.loc * term_pp * term_pp - | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp - | UncoercibleRewrite of term_pp * term_pp -type typing_error = - NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp - | NonConvertible of Util.loc * term_pp * term_pp - | NonSigma of Util.loc * term_pp - | IllSorted of Util.loc * term_pp -exception Subtyping_error of subtyping_error -exception Typing_error of typing_error -exception Debug_msg of string -val typing_error : typing_error -> 'a -val subtyping_error : subtyping_error -> 'a diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml deleted file mode 100644 index 3dcd43d2..00000000 --- a/contrib/subtac/subtac_obligations.ml +++ /dev/null @@ -1,596 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -open Printf -open Pp -open Subtac_utils -open Command -open Environ - -open Term -open Names -open Libnames -open Summary -open Libobject -open Entries -open Decl_kinds -open Util -open Evd -open Declare -open Proof_type - -let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) -let pperror cmd = Util.errorlabstrm "Program" cmd -let error s = pperror (str s) - -exception NoObligations of identifier option - -let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ str (string_of_id ident) - | None -> str "No obligations remaining" - -type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t - * Tacexpr.raw_tactic_expr option) array - -type obligation = - { obl_name : identifier; - obl_type : types; - obl_location : loc; - obl_body : constr option; - obl_status : obligation_definition_status; - obl_deps : Intset.t; - obl_tac : Tacexpr.raw_tactic_expr option; - } - -type obligations = (obligation array * int) - -type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list - -type program_info = { - prg_name: identifier; - prg_body: constr; - prg_type: constr; - prg_obligations: obligations; - prg_deps : identifier list; - prg_fixkind : Command.fixpoint_kind option ; - prg_implicits : (Topconstr.explicitation * (bool * bool)) list; - prg_notations : notations ; - prg_kind : definition_kind; - prg_hook : Tacexpr.declaration_hook; -} - -let assumption_message id = - Flags.if_verbose message ((string_of_id id) ^ " is assumed") - -let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC -let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Tacexpr.TacId []) - -let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t - -(* true = All transparent, false = Opaque if possible *) -let proofs_transparency = ref true - -let set_proofs_transparency = (:=) proofs_transparency -let get_proofs_transparency () = !proofs_transparency - -open Goptions - -let _ = - declare_bool_option - { optsync = true; - optname = "transparency of Program obligations"; - optkey = (SecondaryTable ("Transparent","Obligations")); - optread = get_proofs_transparency; - optwrite = set_proofs_transparency; } - -let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type - -let get_obligation_body expand obl = - let c = Option.get obl.obl_body in - if expand && obl.obl_status = Expand then - match kind_of_term c with - | Const c -> constant_value (Global.env ()) c - | _ -> c - else c - -let subst_deps expand obls deps t = - let subst = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - let oblb = - try get_obligation_body expand xobl - with _ -> assert(false) - in (xobl.obl_name, oblb) :: acc) - deps [] - in(* Termops.it_mkNamedProd_or_LetIn t subst *) - Term.replace_vars subst t - -let subst_deps_obl obls obl = - let t' = subst_deps false obls obl.obl_deps obl.obl_type in - { obl with obl_type = t' } - -module ProgMap = Map.Make(struct type t = identifier let compare = compare end) - -let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) - -let map_cardinal m = - let i = ref 0 in - ProgMap.iter (fun _ _ -> incr i) m; - !i - -exception Found of program_info - -let map_first m = - try - ProgMap.iter (fun _ v -> raise (Found v)) m; - assert(false) - with Found x -> x - -let from_prg : program_info ProgMap.t ref = ref ProgMap.empty - -let freeze () = !from_prg, !default_tactic_expr -let unfreeze (v, t) = from_prg := v; set_default_tactic t -let init () = - from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.tactics_call "obligation_tactic" []) - -let _ = - Summary.declare_summary "program-tcc-table" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_module = false; - Summary.survive_section = false } - -let progmap_union = ProgMap.fold ProgMap.add - -let cache (_, (infos, tac)) = - from_prg := infos; - set_default_tactic tac - -let (input,output) = - declare_object - { (default_object "Program state") with - cache_function = cache; - load_function = (fun _ -> cache); - open_function = (fun _ -> cache); - classify_function = (fun _ -> Dispose); - export_function = (fun x -> Some x) } - -open Evd - -let rec intset_to = function - -1 -> Intset.empty - | n -> Intset.add n (intset_to (pred n)) - -let subst_body expand prg = - let obls, _ = prg.prg_obligations in - let ints = intset_to (pred (Array.length obls)) in - subst_deps expand obls ints prg.prg_body, - subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) - -let declare_definition prg = - let body, typ = subst_body false prg in - (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ - my_print_constr (Global.env()) body ++ str " : " ++ - my_print_constr (Global.env()) prg.prg_type); - with _ -> ()); - let (local, boxed, kind) = prg.prg_kind in - let ce = - { const_entry_body = body; - const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = boxed} - in - (Command.get_declare_definition_hook ()) ce; - match local with - | Local when Lib.sections_are_opened () -> - let c = - SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in - let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in - print_message (Subtac_utils.definition_message prg.prg_name); - if Pfedit.refining () then - Flags.if_verbose msg_warning - (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ - str" is not visible from current goals"); - VarRef prg.prg_name - | (Global|Local) -> - let c = - Declare.declare_constant - prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) - in - let gr = ConstRef c in - if Impargs.is_implicit_args () || prg.prg_implicits <> [] then - Impargs.declare_manual_implicits false gr prg.prg_implicits; - print_message (Subtac_utils.definition_message prg.prg_name); - prg.prg_hook local gr; - gr - -open Pp -open Ppconstr - -let rec lam_index n t acc = - match kind_of_term t with - | Lambda (na, _, b) -> - if na = Name n then acc - else lam_index n b (succ acc) - | _ -> raise Not_found - -let compute_possible_guardness_evidences (n,_) fixbody fixtype = - match n with - | Some (loc, n) -> [lam_index n fixbody 0] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - let m = Term.nb_prod fixtype in - let ctx = fst (Sign.decompose_prod_n_assum m fixtype) in - list_map_i (fun i _ -> i) 0 ctx - -let reduce_fix = - Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty - -let declare_mutual_definition l = - let len = List.length l in - let first = List.hd l in - let fixdefs, fixtypes, fiximps = - list_split3 - (List.map (fun x -> - let subs, typ = (subst_body false x) in - snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l) - in -(* let fixdefs = List.map reduce_fix fixdefs in *) - let fixkind = Option.get first.prg_fixkind in - let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in - let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in - let (local,boxed,kind) = first.prg_kind in - let fixnames = first.prg_deps in - let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in - let indexes, fixdecls = - match fixkind with - | IsFixpoint wfl -> - let possible_indexes = - list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in - let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in - Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l - | IsCoFixpoint -> - None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l - in - (* Declare the recursive definitions *) - let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in - (* Declare notations *) - List.iter (Command.declare_interning_data ([],[])) first.prg_notations; - Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames); - let gr = List.hd kns in - let kn = match gr with ConstRef kn -> kn | _ -> assert false in - first.prg_hook local gr; kn - -let declare_obligation obl body = - match obl.obl_status with - | Expand -> { obl with obl_body = Some body } - | Define opaque -> - let ce = - { const_entry_body = body; - const_entry_type = Some obl.obl_type; - const_entry_opaque = - (if get_proofs_transparency () then false - else opaque) ; - const_entry_boxed = false} - in - let constant = Declare.declare_constant obl.obl_name - (DefinitionEntry ce,IsProof Property) - in - print_message (Subtac_utils.definition_message obl.obl_name); - { obl with obl_body = Some (mkConst constant) } - -let red = Reductionops.nf_betaiota Evd.empty - -let init_prog_info n b t deps fixkind notations obls impls kind hook = - let obls' = - Array.mapi - (fun i (n, t, l, o, d, tac) -> - debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); - { obl_name = n ; obl_body = None; - obl_location = l; obl_type = red t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls - in - { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); - prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; - prg_implicits = impls; prg_kind = kind; prg_hook = hook; } - -let get_prog name = - let prg_infos = !from_prg in - match name with - Some n -> - (try ProgMap.find n prg_infos - with Not_found -> raise (NoObligations (Some n))) - | None -> - (let n = map_cardinal prg_infos in - match n with - 0 -> raise (NoObligations None) - | 1 -> map_first prg_infos - | _ -> error "More than one program with unsolved obligations") - -let get_prog_err n = - try get_prog n with NoObligations id -> pperror (explain_no_obligations id) - -let obligations_solved prg = (snd prg.prg_obligations) = 0 - -let update_state s = -(* msgnl (str "Updating obligations info"); *) - Lib.add_anonymous_leaf (input s) - -type progress = - | Remain of int - | Dependent - | Defined of global_reference - -let obligations_message rem = - if rem > 0 then - if rem = 1 then - Flags.if_verbose msgnl (int rem ++ str " obligation remaining") - else - Flags.if_verbose msgnl (int rem ++ str " obligations remaining") - else - Flags.if_verbose msgnl (str "No more obligations remaining") - -let update_obls prg obls rem = - let prg' = { prg with prg_obligations = (obls, rem) } in - from_prg := map_replace prg.prg_name prg' !from_prg; - obligations_message rem; - let res = - if rem > 0 then Remain rem - else ( - match prg'.prg_deps with - [] -> - let kn = declare_definition prg' in - from_prg := ProgMap.remove prg.prg_name !from_prg; - Defined kn - | l -> - let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in - if List.for_all (fun x -> obligations_solved x) progs then - (let kn = declare_mutual_definition progs in - from_prg := List.fold_left - (fun acc x -> - ProgMap.remove x.prg_name acc) !from_prg progs; - Defined (ConstRef kn)) - else Dependent); - in - update_state (!from_prg, !default_tactic_expr); - res - -let is_defined obls x = obls.(x).obl_body <> None - -let deps_remaining obls deps = - Intset.fold - (fun x acc -> - if is_defined obls x then acc - else x :: acc) - deps [] - -let has_dependencies obls n = - let res = ref false in - Array.iteri - (fun i obl -> - if i <> n && Intset.mem n obl.obl_deps then - res := true) - obls; - !res - -let kind_of_opacity o = - match o with - | Define false | Expand -> Subtac_utils.goal_kind - | _ -> Subtac_utils.goal_proof_kind - -let not_transp_msg = - str "Obligation should be transparent but was declared opaque." ++ spc () ++ - str"Use 'Defined' instead." - -let warn_not_transp () = ppwarn not_transp_msg -let error_not_transp () = pperror not_transp_msg - -let rec solve_obligation prg num = - let user_num = succ num in - let obls, rem = prg.prg_obligations in - let obl = obls.(num) in - if obl.obl_body <> None then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") - else - match deps_remaining obls obl.obl_deps with - | [] -> - let obl = subst_deps_obl obls obl in - Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type - (fun strength gr -> - let cst = match gr with ConstRef cst -> cst | _ -> assert false in - let obl = - let transparent = evaluable_constant cst (Global.env ()) in - let body = - match obl.obl_status with - | Expand -> - if not transparent then error_not_transp () - else constant_value (Global.env ()) cst - | Define opaque -> - if not opaque && not transparent then error_not_transp () - else Libnames.constr_of_global gr - in { obl with obl_body = Some body } - in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - match update_obls prg obls (pred rem) with - | Remain n when n > 0 -> - if has_dependencies obls num then - ignore(auto_solve_obligations (Some prg.prg_name) None) - | _ -> ()); - trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ - Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); - Pfedit.by !default_tactic; - Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) - -and subtac_obligation (user_num, name, typ) = - let num = pred user_num in - let prg = get_prog_err name in - let obls, rem = prg.prg_obligations in - if num < Array.length obls then - let obl = obls.(num) in - match obl.obl_body with - None -> solve_obligation prg num - | Some r -> error "Obligation already solved" - else error (sprintf "Unknown obligation number %i" (succ num)) - - -and solve_obligation_by_tac prg obls i tac = - let obl = obls.(i) in - match obl.obl_body with - Some _ -> false - | None -> - (try - if deps_remaining obls obl.obl_deps = [] then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> Tacinterp.interp t - | None -> !default_tactic - in - let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in - obls.(i) <- declare_obligation obl t; - true - else false - with - | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) - | Stdpp.Exc_located(_, Refiner.FailError (_, s)) - | Refiner.FailError (_, s) -> - user_err_loc (obl.obl_location, "solve_obligation", s) - | e -> false) - -and solve_prg_obligations prg tac = - let obls, rem = prg.prg_obligations in - let rem = ref rem in - let obls' = Array.copy obls in - let _ = - Array.iteri (fun i x -> - if solve_obligation_by_tac prg obls' i tac then - decr rem) - obls' - in - update_obls prg obls' !rem - -and solve_obligations n tac = - let prg = get_prog_err n in - solve_prg_obligations prg tac - -and solve_all_obligations tac = - ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg - -and try_solve_obligation n prg tac = - let prg = get_prog prg in - let obls, rem = prg.prg_obligations in - let obls' = Array.copy obls in - if solve_obligation_by_tac prg obls' n tac then - ignore(update_obls prg obls' (pred rem)); - -and try_solve_obligations n tac = - try ignore (solve_obligations n tac) with NoObligations _ -> () - -and auto_solve_obligations n tac : progress = - Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent - -open Pp -let show_obligations ?(msg=true) n = - let prg = get_prog_err n in - let n = prg.prg_name in - let obls, rem = prg.prg_obligations in - let showed = ref 5 in - if msg then msgnl (int rem ++ str " obligation(s) remaining: "); - Array.iteri (fun i x -> - match x.obl_body with - | None -> - if !showed > 0 then ( - decr showed; - msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ - hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) - | Some _ -> ()) - obls - -let show_term n = - let prg = get_prog_err n in - let n = prg.prg_name in - msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++ - my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () - ++ my_print_constr (Global.env ()) prg.prg_body) - -let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls = - Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); - let prg = init_prog_info n b t [] None [] obls implicits kind hook in - let obls,_ = prg.prg_obligations in - if Array.length obls = 0 then ( - Flags.if_verbose ppnl (str "."); - let cst = declare_definition prg in - from_prg := ProgMap.remove prg.prg_name !from_prg; - Defined cst) - else ( - let len = Array.length obls in - let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in - from_prg := ProgMap.add n prg !from_prg; - let res = auto_solve_obligations (Some n) tactic in - match res with - | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res - | _ -> res) - -let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in - let upd = List.fold_left - (fun acc (n, b, t, imps, obls) -> - let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind hook in - ProgMap.add n prg acc) - !from_prg l - in - from_prg := upd; - let _defined = - List.fold_left (fun finished x -> - if finished then finished - else - let res = auto_solve_obligations (Some x) tactic in - match res with - | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true - | _ -> false) - false deps - in () - -let admit_obligations n = - let prg = get_prog_err n in - let obls, rem = prg.prg_obligations in - Array.iteri (fun i x -> - match x.obl_body with - None -> - let x = subst_deps_obl obls x in - let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), IsAssumption Conjectural) in - assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (mkConst kn) } - | Some _ -> ()) - obls; - ignore(update_obls prg obls 0) - -exception Found of int - -let array_find f arr = - try Array.iteri (fun i x -> if f x then raise (Found i)) arr; - raise Not_found - with Found i -> i - -let next_obligation n = - let prg = get_prog_err n in - let obls, rem = prg.prg_obligations in - let i = - try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls - with Not_found -> anomaly "Could not find a solvable obligation." - in solve_obligation prg i - -let default_tactic () = !default_tactic diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli deleted file mode 100644 index 766af2fa..00000000 --- a/contrib/subtac/subtac_obligations.mli +++ /dev/null @@ -1,63 +0,0 @@ -open Names -open Util -open Libnames -open Evd -open Proof_type - -type obligation_info = - (identifier * Term.types * loc * - obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array - (* ident, type, location, (opaque or transparent, expand or define), - dependencies, tactic to solve it *) - -type progress = (* Resolution status of a program *) - | Remain of int (* n obligations remaining *) - | Dependent (* Dependent on other definitions *) - | Defined of global_reference (* Defined as id *) - -val set_default_tactic : Tacexpr.glob_tactic_expr -> unit -val default_tactic : unit -> Proof_type.tactic - -val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) -val get_proofs_transparency : unit -> bool - -val add_definition : Names.identifier -> Term.constr -> Term.types -> - ?implicits:(Topconstr.explicitation * (bool * bool)) list -> - ?kind:Decl_kinds.definition_kind -> - ?tactic:Proof_type.tactic -> - ?hook:Tacexpr.declaration_hook -> obligation_info -> progress - -type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list - -val add_mutual_definitions : - (Names.identifier * Term.constr * Term.types * - (Topconstr.explicitation * (bool * bool)) list * obligation_info) list -> - ?tactic:Proof_type.tactic -> - ?kind:Decl_kinds.definition_kind -> - ?hook:Tacexpr.declaration_hook -> - notations -> - Command.fixpoint_kind -> unit - -val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit - -val next_obligation : Names.identifier option -> unit - -val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress -(* Number of remaining obligations to be solved for this program *) - -val solve_all_obligations : Proof_type.tactic option -> unit - -val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit - -val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit - -val show_obligations : ?msg:bool -> Names.identifier option -> unit - -val show_term : Names.identifier option -> unit - -val admit_obligations : Names.identifier option -> unit - -exception NoObligations of Names.identifier option - -val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds - diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml deleted file mode 100644 index 3ae7c95d..00000000 --- a/contrib/subtac/subtac_pretyping.ml +++ /dev/null @@ -1,137 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: subtac_pretyping.ml 12187 2009-06-13 19:36:59Z msozeau $ *) - -open Global -open Pp -open Util -open Names -open Sign -open Evd -open Term -open Termops -open Reductionops -open Environ -open Type_errors -open Typeops -open Libnames -open Classops -open List -open Recordops -open Evarutil -open Pretype_errors -open Rawterm -open Evarconv -open Pattern -open Dyn - -open Subtac_coercion -open Subtac_utils -open Coqlib -open Printer -open Subtac_errors -open Eterm - -module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion) - -open Pretyping - -let _ = Pretyping.allow_anonymous_refs := true - -type recursion_info = { - arg_name: name; - arg_type: types; (* A *) - args_after : rel_context; - wf_relation: constr; (* R : A -> A -> Prop *) - wf_proof: constr; (* : well_founded R *) - f_type: types; (* f: A -> Set *) - f_fulltype: types; (* Type with argument and wf proof product first *) -} - -let my_print_rec_info env t = - str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++ - str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++ - str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++ - str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++ - str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++ - str "Full type: " ++ my_print_constr env t.f_fulltype -(* trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *) -(* str " and tycon "++ my_print_tycon env tycon ++ *) -(* str " in environment: " ++ my_print_env env); *) - -let merge_evms x y = - Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y - -let interp env isevars c tycon = - let j = pretype tycon env isevars ([],[]) c in - let _ = isevars := Evarutil.nf_evar_defs !isevars in - let evd,_ = consider_remaining_unif_problems env !isevars in -(* let unevd = undefined_evars evd in *) - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in - let evm = evars_of unevd' in - isevars := unevd'; - nf_evar evm j.uj_val, nf_evar evm j.uj_type - -let find_with_index x l = - let rec aux i = function - (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl - | [] -> raise Not_found - in aux 0 l - -open Vernacexpr - -let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env -let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type (evars_of evd) env - -let env_with_binders env isevars l = - let rec aux ((env, rels) as acc) = function - Topconstr.LocalRawDef ((loc, name), def) :: tl -> - let rawdef = coqintern_constr !isevars env def in - let coqdef, deftyp = interp env isevars rawdef empty_tycon in - let reldecl = (name, Some coqdef, deftyp) in - aux (push_rel reldecl env, reldecl :: rels) tl - | Topconstr.LocalRawAssum (bl, k, typ) :: tl -> - let rawtyp = coqintern_type !isevars env typ in - let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in - let acc = - List.fold_left (fun (env, rels) (loc, name) -> - let reldecl = (name, None, coqtyp) in - (push_rel reldecl env, - reldecl :: rels)) - (env, rels) bl - in aux acc tl - | [] -> acc - in aux (env, []) l - -let subtac_process env isevars id bl c tycon = - let c = Command.abstract_constr_expr c bl in - let tycon = - match tycon with - None -> empty_tycon - | Some t -> - let t = Command.generalize_constr_expr t bl in - let t = coqintern_type !isevars env t in - let coqt, ttyp = interp env isevars t empty_tycon in - mk_tycon coqt - in - let c = coqintern_constr !isevars env c in - let imps = Implicit_quantifiers.implicits_of_rawterm c in - let coqc, ctyp = interp env isevars c tycon in - let evm = non_instanciated_map env isevars (evars_of !isevars) in - let ty = nf_isevar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in - evm, coqc, ty, imps - -open Subtac_obligations - -let subtac_proof kind hook env isevars id bl c tycon = - let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in - let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in - let evm' = Subtac_utils.evars_of_term evm evm' coqt in - let evars, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in - add_definition id def ty ~implicits:imps ~kind ~hook evars diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli deleted file mode 100644 index ba0b7cd2..00000000 --- a/contrib/subtac/subtac_pretyping.mli +++ /dev/null @@ -1,24 +0,0 @@ -open Term -open Environ -open Names -open Sign -open Evd -open Global -open Topconstr -open Implicit_quantifiers -open Impargs - -module Pretyping : Pretyping.S - -val interp : - Environ.env -> - Evd.evar_defs ref -> - Rawterm.rawconstr -> - Evarutil.type_constraint -> Term.constr * Term.constr - -val subtac_process : env -> evar_defs ref -> identifier -> local_binder list -> - constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list - -val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> - env -> evar_defs ref -> identifier -> local_binder list -> - constr_expr -> constr_expr option -> Subtac_obligations.progress diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml deleted file mode 100644 index 00d37f35..00000000 --- a/contrib/subtac/subtac_pretyping_F.ml +++ /dev/null @@ -1,641 +0,0 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* $Id: subtac_pretyping_F.ml 11576 2008-11-10 19:13:15Z msozeau $ *) - -open Pp -open Util -open Names -open Sign -open Evd -open Term -open Termops -open Reductionops -open Environ -open Type_errors -open Typeops -open Libnames -open Nameops -open Classops -open List -open Recordops -open Evarutil -open Pretype_errors -open Rawterm -open Evarconv -open Pattern -open Dyn -open Pretyping - -(************************************************************************) -(* This concerns Cases *) -open Declarations -open Inductive -open Inductiveops - -module SubtacPretyping_F (Coercion : Coercion.S) = struct - - module Cases = Subtac_cases.Cases_F(Coercion) - - (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) - let allow_anonymous_refs = ref true - - let evd_comb0 f isevars = - let (evd',x) = f !isevars in - isevars := evd'; - x - - let evd_comb1 f isevars x = - let (evd',y) = f !isevars x in - isevars := evd'; - y - - let evd_comb2 f isevars x y = - let (evd',z) = f !isevars x y in - isevars := evd'; - z - - let evd_comb3 f isevars x y z = - let (evd',t) = f !isevars x y z in - isevars := evd'; - t - - let mt_evd = Evd.empty - - (* Utilisé pour inférer le prédicat des Cases *) - (* Semble exagérement fort *) - (* Faudra préférer une unification entre les types de toutes les clauses *) - (* et autoriser des ? à rester dans le résultat de l'unification *) - - let evar_type_fixpoint loc env isevars lna lar vdefj = - let lt = Array.length vdefj in - if Array.length lar = lt then - for i = 0 to lt-1 do - if not (e_cumul env isevars (vdefj.(i)).uj_type - (lift lt lar.(i))) then - error_ill_typed_rec_body_loc loc env (evars_of !isevars) - i lna vdefj lar - done - - let check_branches_message loc env isevars c (explft,lft) = - for i = 0 to Array.length explft - 1 do - if not (e_cumul env isevars lft.(i) explft.(i)) then - let sigma = evars_of !isevars in - error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) - done - - (* coerce to tycon if any *) - let inh_conv_coerce_to_tycon loc env isevars j = function - | None -> j_nf_isevar !isevars j - | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t - - let push_rels vars env = List.fold_right push_rel vars env - - (* - let evar_type_case isevars env ct pt lft p c = - let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c - in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty) - *) - - let strip_meta id = (* For Grammar v7 compatibility *) - let s = string_of_id id in - if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) - else id - - let pretype_id loc env (lvar,unbndltacvars) id = - let id = strip_meta id in (* May happen in tactics defined by Grammar *) - try - let (n,typ) = lookup_rel_id id (rel_context env) in - { uj_val = mkRel n; uj_type = lift n typ } - with Not_found -> - try - List.assoc id lvar - with Not_found -> - try - let (_,_,typ) = lookup_named id env in - { uj_val = mkVar id; uj_type = typ } - with Not_found -> - try (* To build a nicer ltac error message *) - match List.assoc id unbndltacvars with - | None -> user_err_loc (loc,"", - str "variable " ++ pr_id id ++ str " should be bound to a term") - | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 - with Not_found -> - error_var_not_found_loc loc id - - (* make a dependent predicate from an undependent one *) - - let make_dep_of_undep env (IndType (indf,realargs)) pj = - let n = List.length realargs in - let rec decomp n p = - if n=0 then p else - match kind_of_term p with - | Lambda (_,_,c) -> decomp (n-1) c - | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) - in - let sign,s = decompose_prod_n n pj.uj_type in - let ind = build_dependent_inductive env indf in - let s' = mkProd (Anonymous, ind, s) in - let ccl = lift 1 (decomp n pj.uj_val) in - let ccl' = mkLambda (Anonymous, ind, ccl) in - {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} - - (*************************************************************************) - (* Main pretyping function *) - - let pretype_ref isevars env ref = - let c = constr_of_global ref in - make_judge c (Retyping.get_type_of env Evd.empty c) - - let pretype_sort = function - | RProp c -> judge_of_prop_contents c - | RType _ -> judge_of_new_Type () - - (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *) - (* in environment [env], with existential variables [(evars_of isevars)] and *) - (* the type constraint tycon *) - let rec pretype (tycon : type_constraint) env isevars lvar c = -(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) -(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) -(* with _ -> () *) -(* in *) - match c with - | RRef (loc,ref) -> - inh_conv_coerce_to_tycon loc env isevars - (pretype_ref isevars env ref) - tycon - - | RVar (loc, id) -> - inh_conv_coerce_to_tycon loc env isevars - (pretype_id loc env lvar id) - tycon - - | REvar (loc, ev, instopt) -> - (* Ne faudrait-il pas s'assurer que hyps est bien un - sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) - let hyps = evar_context (Evd.find (evars_of !isevars) ev) in - let args = match instopt with - | None -> instance_from_named_context hyps - | Some inst -> failwith "Evar subtitutions not implemented" in - let c = mkEvar (ev, args) in - let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in - inh_conv_coerce_to_tycon loc env isevars j tycon - - | RPatVar (loc,(someta,n)) -> - anomaly "Found a pattern variable in a rawterm to type" - - | RHole (loc,k) -> - let ty = - match tycon with - | Some (None, ty) -> ty - | None | Some _ -> - e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in - { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty } - - | RRec (loc,fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - [] -> ctxt - | (na,k,None,ty)::bl -> - let ty' = pretype_type empty_valcon env isevars lvar ty in - let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,k,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env isevars lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in - let larj = - array_map2 - (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) isevars lvar ar) - ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in - let nbfix = Array.length lar in - let names = Array.map (fun id -> Name id) names in - (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in - let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in - let vdefj = - array_map2_i - (fun i ctxt def -> - let fty = - let ty = ftys.(i) in - if i = fixi then ( - Option.iter (fun tycon -> - isevars := Coercion.inh_conv_coerces_to loc env !isevars ftys.(i) tycon) - tycon; - nf_isevar !isevars ty) - else ty - in - (* we lift nbfix times the type in tycon, because of - * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix fty) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv isevars lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evar_type_fixpoint loc env isevars names ftys vdefj; - let ftys = Array.map (nf_evar (evars_of !isevars)) ftys in - let fdefs = Array.map (fun x -> nf_evar (evars_of !isevars) (j_val x)) vdefj in - let fixj = match fixkind with - | RFix (vn,i) -> - (* First, let's find the guard indexes. *) - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem worth the effort (except for huge mutual - fixpoints ?) *) - let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with - | Some n -> [n] - | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | RCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); - make_judge (mkCoFix cofix) ftys.(i) in - inh_conv_coerce_to_tycon loc env isevars fixj tycon - - | RSort (loc,s) -> - inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon - - | RApp (loc,f,args) -> - let length = List.length args in - let ftycon = - let ty = - if length > 0 then - match tycon with - | None -> None - | Some (None, ty) -> mk_abstr_tycon length ty - | Some (Some (init, cur), ty) -> - Some (Some (length + init, length + cur), ty) - else tycon - in - match ty with - | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty - | _ -> None - in - let fj = pretype ftycon env isevars lvar f in - let floc = loc_of_rawconstr f in - let rec apply_rec env n resj tycon = function - | [] -> resj - | c::rest -> - let argloc = loc_of_rawconstr c in - let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in - let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in - match kind_of_term resty with - | Prod (na,c1,c2) -> - Option.iter (fun ty -> isevars := - Coercion.inh_conv_coerces_to loc env !isevars resty ty) tycon; - let evd, (_, _, tycon) = split_tycon loc env !isevars tycon in - isevars := evd; - let hj = pretype (mk_tycon (nf_isevar !isevars c1)) env isevars lvar c in - let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in - let typ' = nf_isevar !isevars typ in - apply_rec env (n+1) - { uj_val = nf_isevar !isevars value; - uj_type = nf_isevar !isevars typ' } - (Option.map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest - - | _ -> - let hj = pretype empty_tycon env isevars lvar c in - error_cant_apply_not_functional_loc - (join_loc floc argloc) env (evars_of !isevars) - resj [hj] - in - let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in - let resj = - match kind_of_term resj.uj_val with - | App (f,args) when isInd f or isConst f -> - let sigma = evars_of !isevars in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let t = Retyping.get_type_of env sigma c in - make_judge c t - | _ -> resj in - inh_conv_coerce_to_tycon loc env isevars resj tycon - - | RLambda(loc,name,k,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - isevars tycon - in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon' in - let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env isevars lvar c1 in - let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) isevars lvar c2 in - let resj = judge_of_abstraction env name j j' in - inh_conv_coerce_to_tycon loc env isevars resj tycon - - | RProd(loc,name,k,c1,c2) -> - let j = pretype_type empty_valcon env isevars lvar c1 in - let var = (name,j.utj_val) in - let env' = push_rel_assum var env in - let j' = pretype_type empty_valcon env' isevars lvar c2 in - let resj = - try judge_of_product env name j j' - with TypeError _ as e -> Stdpp.raise_with_loc loc e in - inh_conv_coerce_to_tycon loc env isevars resj tycon - - | RLetIn(loc,name,c1,c2) -> - let j = pretype empty_tycon env isevars lvar c1 in - let t = refresh_universes j.uj_type in - let var = (name,Some j.uj_val,t) in - let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) isevars lvar c2 in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } - - | RLetTuple (loc,nal,(na,po),c,d) -> - let cj = pretype empty_tycon env isevars lvar c in - let (IndType (indf,realargs)) = - try find_rectype env (evars_of !isevars) cj.uj_type - with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env (evars_of !isevars) cj - in - let cstrs = get_constructors env indf in - if Array.length cstrs <> 1 then - user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); - let cs = cstrs.(0) in - if List.length nal <> cs.cs_nargs then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rels fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let nar = List.length arsgn in - (match po with - | Some p -> - let env_p = push_rels psign env in - let pj = pretype_type empty_valcon env_p isevars lvar p in - let ccl = nf_evar (evars_of !isevars) pj.utj_val in - let psign = make_arity_signature env true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in - let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in - let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env (evars_of !isevars) lp inst in - let fj = pretype (mk_tycon fty) env_f isevars lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let v = - let mis,_ = dest_ind_family indf in - let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f isevars lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar (evars_of !isevars) fj.uj_type in - let ccl = - if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else - error_cant_find_case_type_loc loc env (evars_of !isevars) - cj.uj_val in - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in - let v = - let mis,_ = dest_ind_family indf in - let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|] ) - in - { uj_val = v; uj_type = ccl }) - - | RIf (loc,c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env isevars lvar c in - let (IndType (indf,realargs)) = - try find_rectype env (evars_of !isevars) cj.uj_type - with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env (evars_of !isevars) cj in - let cstrs = get_constructors env indf in - if Array.length cstrs <> 2 then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors"); - - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let nar = List.length arsgn in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let pred,p = match po with - | Some p -> - let env_p = push_rels psign env in - let pj = pretype_type empty_valcon env_p isevars lvar p in - let ccl = nf_evar (evars_of !isevars) pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in - let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred; - uj_type = typ} tycon - in - jtyp.uj_val, jtyp.uj_type - | None -> - let p = match tycon with - | Some (None, ty) -> ty - | None | Some _ -> - e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) - in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar (evars_of !isevars) pred in - let p = nf_evar (evars_of !isevars) p in - (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*) - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name (id_of_string "H"), b, t)) - cs.cs_args - in - let env_c = push_rels csgn env in -(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) - let bj = pretype (mk_tycon pi) env_c isevars lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in - let v = - let mis,_ = dest_ind_family indf in - let ci = make_case_info env mis IfStyle in - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) - in - { uj_val = v; uj_type = p } - - | RCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty - ((fun vtyc env isevars -> pretype vtyc env isevars lvar),isevars) - tycon env (* loc *) (po,tml,eqns) - - | RCast(loc,c,k) -> - let cj = - match k with - CastCoerce -> - let cj = pretype empty_tycon env isevars lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj - | CastConv (k,t) -> - let tj = pretype_type empty_valcon env isevars lvar t in - let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in - (* User Casts are for helping pretyping, experimentally not to be kept*) - (* ... except for Correctness *) - let v = mkCast (cj.uj_val, k, tj.utj_val) in - { uj_val = v; uj_type = tj.utj_val } - in - inh_conv_coerce_to_tycon loc env isevars cj tycon - - | RDynamic (loc,d) -> - if (tag d) = "constr" then - let c = constr_out d in - let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in - j - (*inh_conv_coerce_to_tycon loc env isevars j tycon*) - else - user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic")) - - (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *) - and pretype_type valcon env isevars lvar = function - | RHole loc -> - (match valcon with - | Some v -> - let s = - let sigma = evars_of !isevars in - let t = Retyping.get_type_of env sigma v in - match kind_of_term (whd_betadeltaiota env sigma t) with - | Sort s -> s - | Evar v when is_Type (existential_type sigma v) -> - evd_comb1 (define_evar_as_sort) isevars v - | _ -> anomaly "Found a type constraint which is not a type" - in - { utj_val = v; - utj_type = s } - | None -> - let s = new_Type_sort () in - { utj_val = e_new_evar isevars env ~src:loc (mkSort s); - utj_type = s}) - | c -> - let j = pretype empty_tycon env isevars lvar c in - let loc = loc_of_rawconstr c in - let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in - match valcon with - | None -> tj - | Some v -> - if e_cumul env isevars v tj.utj_val then tj - else - error_unexpected_type_loc - (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v - - let pretype_gen_aux isevars env lvar kind c = - let c' = match kind with - | OfType exptyp -> - let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in - (pretype tycon env isevars lvar c).uj_val - | IsType -> - (pretype_type empty_valcon env isevars lvar c).utj_val in - let evd,_ = consider_remaining_unif_problems env !isevars in - isevars:=evd; - nf_evar (evars_of !isevars) c' - - let pretype_gen isevars env lvar kind c = - let c = pretype_gen_aux isevars env lvar kind c in - isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !isevars; - nf_evar (evars_of !isevars) c - - (* TODO: comment faire remonter l'information si le typage a resolu des - variables du sigma original. il faudrait que la fonction de typage - retourne aussi le nouveau sigma... - *) - - let understand_judgment sigma env c = - let isevars = ref (create_evar_defs sigma) in - let j = pretype empty_tycon env isevars ([],[]) c in - let j = j_nf_evar (evars_of !isevars) j in - let isevars,_ = consider_remaining_unif_problems env !isevars in - check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); - j - - let understand_judgment_tcc isevars env c = - let j = pretype empty_tycon env isevars ([],[]) c in - let sigma = evars_of !isevars in - let j = j_nf_evar sigma j in - j - - (* Raw calls to the unsafe inference machine: boolean says if we must - fail on unresolved evars; the unsafe_judgment list allows us to - extend env with some bindings *) - - let ise_pretype_gen fail_evar sigma env lvar kind c = - let isevars = ref (Evd.create_evar_defs sigma) in - let c = pretype_gen isevars env lvar kind c in - let evd = !isevars in - if fail_evar then check_evars env Evd.empty evd c; - evd, c - - (** Entry points of the high-level type synthesis algorithm *) - - let understand_gen kind sigma env c = - snd (ise_pretype_gen true sigma env ([],[]) kind c) - - let understand sigma env ?expected_type:exptyp c = - snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c) - - let understand_type sigma env c = - snd (ise_pretype_gen false sigma env ([],[]) IsType c) - - let understand_ltac sigma env lvar kind c = - ise_pretype_gen false sigma env lvar kind c - - let understand_tcc_evars evdref env kind c = - pretype_gen evdref env ([],[]) kind c - - let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = - let ev, t = - if resolve_classes then - ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c - else - let isevars = ref (Evd.create_evar_defs sigma) in - let c = pretype_gen_aux isevars env ([],[]) (OfType exptyp) c in - !isevars, c - in - Evd.evars_of ev, t -end - -module Default : S = SubtacPretyping_F(Coercion.Default) diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml deleted file mode 100644 index 2ee2018e..00000000 --- a/contrib/subtac/subtac_utils.ml +++ /dev/null @@ -1,474 +0,0 @@ -open Evd -open Libnames -open Coqlib -open Term -open Names -open Util - -let ($) f x = f x - -(****************************************************************************) -(* Library linking *) - -let contrib_name = "Program" - -let subtac_dir = [contrib_name] -let fix_sub_module = "Wf" -let utils_module = "Utils" -let fixsub_module = subtac_dir @ [fix_sub_module] -let utils_module = subtac_dir @ [utils_module] -let init_constant dir s = gen_constant contrib_name dir s -let init_reference dir s = gen_reference contrib_name dir s - -let fixsub = lazy (init_constant fixsub_module "Fix_sub") -let ex_pi1 = lazy (init_constant utils_module "ex_pi1") -let ex_pi2 = lazy (init_constant utils_module "ex_pi2") - -let make_ref l s = lazy (init_reference l s) -let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded" -let acc_ref = make_ref ["Init";"Wf"] "Acc" -let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv" -let fix_sub_ref = make_ref fixsub_module "Fix_sub" -let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub" -let lt_ref = make_ref ["Init";"Peano"] "lt" -let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf" -let refl_ref = make_ref ["Init";"Logic"] "refl_equal" - -let make_ref s = Qualid (dummy_loc, qualid_of_string s) -let sig_ref = make_ref "Init.Specif.sig" -let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" -let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" - -let build_sig () = - { proj1 = init_constant ["Init"; "Specif"] "proj1_sig"; - proj2 = init_constant ["Init"; "Specif"] "proj2_sig"; - elim = init_constant ["Init"; "Specif"] "sig_rec"; - intro = init_constant ["Init"; "Specif"] "exist"; - typ = init_constant ["Init"; "Specif"] "sig" } - -let sig_ = lazy (build_sig ()) - -let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq") -let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec") -let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect") -let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal") -let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq") -let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") - -let not_ref = lazy (init_constant ["Init"; "Logic"] "not") - -let and_typ = lazy (Coqlib.build_coq_and ()) - -let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep") -let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") -let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") -let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") - -let jmeq_ind () = - check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq" - -let jmeq_rec () = - check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_rec" - -let jmeq_refl () = - check_required_library ["Coq";"Logic";"JMeq"]; - init_constant ["Logic";"JMeq"] "JMeq_refl" - -let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") -let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") - -let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1") -let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2") - -let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool") -let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool") -let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") -let intind = lazy (init_constant ["ZArith"; "binint"] "Z") -let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") - -let existS = lazy (build_sigma_type ()) - -let prod = lazy (build_prod ()) - - -(* orders *) -let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded") -let fix = lazy (init_constant ["Init"; "Wf"] "Fix") -let acc = lazy (init_constant ["Init"; "Wf"] "Acc") -let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv") - -let extconstr = Constrextern.extern_constr true (Global.env ()) -let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s) - -open Pp - -let my_print_constr = Termops.print_constr_env -let my_print_constr_expr = Ppconstr.pr_constr_expr -let my_print_rel_context env ctx = Printer.pr_rel_context env ctx -let my_print_context = Termops.print_rel_context -let my_print_named_context = Termops.print_named_context -let my_print_env = Termops.print_env -let my_print_rawconstr = Printer.pr_rawconstr_env -let my_print_evardefs = Evd.pr_evar_defs - -let my_print_tycon_type = Evarutil.pr_tycon_type - -let debug_level = 2 - -let debug_on = true - -let debug n s = - if debug_on then - if !Flags.debug && n >= debug_level then - msgnl s - else () - else () - -let debug_msg n s = - if debug_on then - if !Flags.debug && n >= debug_level then s - else mt () - else mt () - -let trace s = - if debug_on then - if !Flags.debug && debug_level > 0 then msgnl s - else () - else () - -let rec pp_list f = function - [] -> mt() - | x :: y -> f x ++ spc () ++ pp_list f y - -let wf_relations = Hashtbl.create 10 - -let std_relations () = - let add k v = Hashtbl.add wf_relations k v in - add (init_constant ["Init"; "Peano"] "lt") - (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf")) - -let std_relations = Lazy.lazy_from_fun std_relations - -type binders = Topconstr.local_binder list - -let app_opt c e = - match c with - Some constr -> constr e - | None -> e - -let print_args env args = - Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") - -let make_existential loc ?(opaque = Define true) env isevars c = - let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in - let (key, args) = destEvar evar in - (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args ++ str " for type: "++ - my_print_constr env c) with _ -> ()); - evar - -let make_existential_expr loc env c = - let key = Evarutil.new_untyped_evar () in - let evar = Topconstr.CEvar (loc, key, None) in - debug 2 (str "Constructed evar " ++ int key); - evar - -let string_of_hole_kind = function - | ImplicitArg _ -> "ImplicitArg" - | BinderType _ -> "BinderType" - | QuestionMark _ -> "QuestionMark" - | CasesType -> "CasesType" - | InternalHole -> "InternalHole" - | TomatchTypeParameter _ -> "TomatchTypeParameter" - | GoalEvar -> "GoalEvar" - | ImpossibleCase -> "ImpossibleCase" - -let evars_of_term evc init c = - let rec evrec acc c = - match kind_of_term c with - | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) - | Evar (n, _) -> assert(false) - | _ -> fold_constr evrec acc c - in - evrec init c - -let non_instanciated_map env evd evm = - List.fold_left - (fun evm (key, evi) -> - let (loc,k) = evar_source key !evd in - debug 2 (str "evar " ++ int key ++ str " has kind " ++ - str (string_of_hole_kind k)); - match k with - QuestionMark _ -> Evd.add evm key evi - | _ -> - debug 2 (str " and is an implicit"); - Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None) - Evd.empty (Evarutil.non_instantiated evm) - -let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition -let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition - -let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma -let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma - -let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint -let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint - -open Tactics -open Tacticals - -let id x = x -let filter_map f l = - let rec aux acc = function - hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl - | None -> aux acc tl) - | [] -> List.rev acc - in aux [] l - -let build_dependent_sum l = - let rec aux names conttac conttype = function - (n, t) :: ((_ :: _) as tl) -> - let hyptype = substl names t in - trace (spc () ++ str ("treating evar " ^ string_of_id n)); - (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) - with _ -> ()); - let tac = assert_tac (Name n) hyptype in - let conttac = - (fun cont -> - conttac - (tclTHENS tac - ([intros; - (tclTHENSEQ - [constructor_tac false (Some 1) 1 - (Rawterm.ImplicitBindings [inj_open (mkVar n)]); - cont]); - ]))) - in - let conttype = - (fun typ -> - let tex = mkLambda (Name n, t, typ) in - conttype - (mkApp (Lazy.force ex_ind, [| t; tex |]))) - in - aux (mkVar n :: names) conttac conttype tl - | (n, t) :: [] -> - (conttac intros, conttype t) - | [] -> raise (Invalid_argument "build_dependent_sum") - in aux [] id id (List.rev l) - -open Proof_type -open Tacexpr - -let mkProj1 a b c = - mkApp (Lazy.force proj1, [| a; b; c |]) - -let mkProj2 a b c = - mkApp (Lazy.force proj2, [| a; b; c |]) - -let mk_ex_pi1 a b c = - mkApp (Lazy.force ex_pi1, [| a; b; c |]) - -let mk_ex_pi2 a b c = - mkApp (Lazy.force ex_pi2, [| a; b; c |]) - -let mkSubset name typ prop = - mkApp ((Lazy.force sig_).typ, - [| typ; mkLambda (name, typ, prop) |]) - -let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) -let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = mkApp (jmeq_ind (), [| typ; x ; typ'; y |]) -let mk_JMeq_refl typ x = mkApp (jmeq_refl (), [| typ; x |]) - -let unsafe_fold_right f = function - hd :: tl -> List.fold_right f tl hd - | [] -> raise (Invalid_argument "unsafe_fold_right") - -let mk_conj l = - let conj_typ = Lazy.force and_typ in - unsafe_fold_right - (fun c conj -> - mkApp (conj_typ, [| c ; conj |])) - l - -let mk_not c = - let notc = Lazy.force not_ref in - mkApp (notc, [| c |]) - -let and_tac l hook = - let andc = Coqlib.build_coq_and () in - let rec aux ((accid, goal, tac, extract) as acc) = function - | [] -> (* Singleton *) acc - - | (id, x, elgoal, eltac) :: tl -> - let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in - let proj = fun c -> mkProj2 goal elgoal c in - let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in - aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', - (id, x, elgoal, proj) :: extract) tl - - in - let and_proof_id, and_goal, and_tac, and_extract = - match l with - | [] -> raise (Invalid_argument "and_tac: empty list of goals") - | (hdid, x, hdg, hdt) :: tl -> - aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl - in - let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in - Command.start_proof and_proofid goal_kind and_goal - (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract)); - trace (str "Started and proof"); - Pfedit.by and_tac; - trace (str "Applied and tac") - - -let destruct_ex ext ex = - let rec aux c acc = - match kind_of_term c with - App (f, args) -> - (match kind_of_term f with - Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 -> - let (dom, rng) = - try (args.(0), args.(1)) - with _ -> assert(false) - in - let pi1 = (mk_ex_pi1 dom rng acc) in - let rng_body = - match kind_of_term rng with - Lambda (_, _, t) -> subst1 pi1 t - | t -> rng - in - pi1 :: aux rng_body (mk_ex_pi2 dom rng acc) - | _ -> [acc]) - | _ -> [acc] - in aux ex ext - -open Rawterm - -let id_of_name = function - Name n -> n - | Anonymous -> raise (Invalid_argument "id_of_name") - -let definition_message id = - Nameops.pr_id id ++ str " is defined" - -let recursive_message v = - match Array.length v with - | 0 -> error "no recursive definition" - | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined") - | _ -> hov 0 (prvect_with_sep pr_coma (Printer.pr_constant (Global.env ())) v ++ - spc () ++ str "are recursively defined") - -let print_message m = - Flags.if_verbose ppnl m - -(* Solve an obligation using tactics, return the corresponding proof term *) -let solve_by_tac evi t = - let id = id_of_string "H" in - try - Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl - (fun _ _ -> ()); - Pfedit.by (tclCOMPLETE t); - let _,(const,_,_,_) = Pfedit.cook_proof ignore in - Pfedit.delete_current_proof (); const.Entries.const_entry_body - with e -> - Pfedit.delete_current_proof(); - raise e - -(* let apply_tac t goal = t goal *) - -(* let solve_by_tac evi t = *) -(* let ev = 1 in *) -(* let evm = Evd.add Evd.empty ev evi in *) -(* let goal = {it = evi; sigma = evm } in *) -(* let (res, valid) = apply_tac t goal in *) -(* if res.it = [] then *) -(* let prooftree = valid [] in *) -(* let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *) -(* if obls = [] then proofterm *) -(* else raise Exit *) -(* else raise Exit *) - -let rec string_of_list sep f = function - [] -> "" - | x :: [] -> f x - | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl - -let string_of_intset d = - string_of_list "," string_of_int (Intset.elements d) - -(**********************************************************) -(* Pretty-printing *) -open Printer -open Ppconstr -open Nameops -open Termops -open Evd - -let pr_meta_map evd = - let ml = meta_list evd in - let pr_name = function - Name id -> str"[" ++ pr_id id ++ str"]" - | _ -> mt() in - let pr_meta_binding = function - | (mv,Cltyp (na,b)) -> - hov 0 - (pr_meta mv ++ pr_name na ++ str " : " ++ - print_constr b.rebus ++ fnl ()) - | (mv,Clval(na,b,_)) -> - hov 0 - (pr_meta mv ++ pr_name na ++ str " := " ++ - print_constr (fst b).rebus ++ fnl ()) - in - prlist pr_meta_binding ml - -let pr_idl idl = prlist_with_sep pr_spc pr_id idl - -let pr_evar_info evi = - let phyps = - (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) - Printer.pr_named_context (Global.env()) (evar_context evi) - in - let pty = print_constr evi.evar_concl in - let pb = - match evi.evar_body with - | Evar_empty -> mt () - | Evar_defined c -> spc() ++ str"=> " ++ print_constr c - in - hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") - -let pr_evar_map sigma = - h 0 - (prlist_with_sep pr_fnl - (fun (ev,evi) -> - h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) - (to_list sigma)) - -let pr_constraints pbs = - h 0 - (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> - print_constr t1 ++ spc() ++ - str (match pbty with - | Reduction.CONV -> "==" - | Reduction.CUMUL -> "<=") ++ - spc() ++ print_constr t2) pbs) - -let pr_evar_defs evd = - let pp_evm = - let evars = evars_of evd in - if evars = empty then mt() else - str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in - let pp_met = - if meta_list evd = [] then mt() else - str"METAS:"++brk(0,1)++pr_meta_map evd in - v 0 (pp_evm ++ pp_met) - -let contrib_tactics_path = - make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"]) -let tactics_tac s = - lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)) - -let tactics_call tac args = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli deleted file mode 100644 index 9c014286..00000000 --- a/contrib/subtac/subtac_utils.mli +++ /dev/null @@ -1,133 +0,0 @@ -open Term -open Libnames -open Coqlib -open Environ -open Pp -open Evd -open Decl_kinds -open Topconstr -open Rawterm -open Util -open Evarutil -open Names -open Sign - -val ($) : ('a -> 'b) -> 'a -> 'b -val contrib_name : string -val subtac_dir : string list -val fix_sub_module : string -val fixsub_module : string list -val init_constant : string list -> string -> constr -val init_reference : string list -> string -> global_reference -val fixsub : constr lazy_t -val well_founded_ref : global_reference lazy_t -val acc_ref : global_reference lazy_t -val acc_inv_ref : global_reference lazy_t -val fix_sub_ref : global_reference lazy_t -val fix_measure_sub_ref : global_reference lazy_t -val lt_ref : global_reference lazy_t -val lt_wf_ref : global_reference lazy_t -val refl_ref : global_reference lazy_t -val sig_ref : reference -val proj1_sig_ref : reference -val proj2_sig_ref : reference -val build_sig : unit -> coq_sigma_data -val sig_ : coq_sigma_data lazy_t - -val eq_ind : constr lazy_t -val eq_rec : constr lazy_t -val eq_rect : constr lazy_t -val eq_refl : constr lazy_t - -val not_ref : constr lazy_t -val and_typ : constr lazy_t - -val eqdep_ind : constr lazy_t -val eqdep_rec : constr lazy_t - -val jmeq_ind : unit -> constr -val jmeq_rec : unit -> constr -val jmeq_refl : unit -> constr - -val boolind : constr lazy_t -val sumboolind : constr lazy_t -val natind : constr lazy_t -val intind : constr lazy_t -val existSind : constr lazy_t -val existS : coq_sigma_data lazy_t -val prod : coq_sigma_data lazy_t - -val well_founded : constr lazy_t -val fix : constr lazy_t -val acc : constr lazy_t -val acc_inv : constr lazy_t -val extconstr : constr -> constr_expr -val extsort : sorts -> constr_expr - -val my_print_constr : env -> constr -> std_ppcmds -val my_print_constr_expr : constr_expr -> std_ppcmds -val my_print_evardefs : evar_defs -> std_ppcmds -val my_print_context : env -> std_ppcmds -val my_print_rel_context : env -> rel_context -> std_ppcmds -val my_print_named_context : env -> std_ppcmds -val my_print_env : env -> std_ppcmds -val my_print_rawconstr : env -> rawconstr -> std_ppcmds -val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds - - -val debug : int -> std_ppcmds -> unit -val debug_msg : int -> std_ppcmds -> std_ppcmds -val trace : std_ppcmds -> unit -val wf_relations : (constr, constr lazy_t) Hashtbl.t - -type binders = local_binder list -val app_opt : ('a -> 'a) option -> 'a -> 'a -val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> ?opaque:obligation_definition_status -> - env -> evar_defs ref -> types -> constr -val make_existential_expr : loc -> 'a -> 'b -> constr_expr -val string_of_hole_kind : hole_kind -> string -val evars_of_term : evar_map -> evar_map -> constr -> evar_map -val non_instanciated_map : env -> evar_defs ref -> evar_map -> evar_map -val global_kind : logical_kind -val goal_kind : locality * goal_object_kind -val global_proof_kind : logical_kind -val goal_proof_kind : locality * goal_object_kind -val global_fix_kind : logical_kind -val goal_fix_kind : locality * goal_object_kind - -val mkSubset : name -> constr -> constr -> constr -val mkProj1 : constr -> constr -> constr -> constr -val mkProj1 : constr -> constr -> constr -> constr -val mk_ex_pi1 : constr -> constr -> constr -> constr -val mk_ex_pi1 : constr -> constr -> constr -> constr -val mk_eq : types -> constr -> constr -> types -val mk_eq_refl : types -> constr -> constr -val mk_JMeq : types -> constr -> types -> constr -> types -val mk_JMeq_refl : types -> constr -> constr -val mk_conj : types list -> types -val mk_not : types -> types - -val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types -val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> - ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit - -val destruct_ex : constr -> constr -> constr list - -val id_of_name : name -> identifier - -val definition_message : identifier -> std_ppcmds -val recursive_message : constant array -> std_ppcmds - -val print_message : std_ppcmds -> unit - -val solve_by_tac : evar_info -> Tacmach.tactic -> constr - -val string_of_list : string -> ('a -> string) -> 'a list -> string -val string_of_intset : Intset.t -> string - -val pr_evar_defs : evar_defs -> Pp.std_ppcmds - -val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr - -val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v deleted file mode 100644 index da612c43..00000000 --- a/contrib/subtac/test/ListDep.v +++ /dev/null @@ -1,49 +0,0 @@ -(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) -Require Import List. -Require Import Coq.Program.Program. - -Set Implicit Arguments. - -Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l. - -Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'. -Proof. - intros. - inversion H. - split. - intros. - apply H0. - auto with datatypes. - auto with arith. -Qed. - -Section Map_DependentRecursor. - Variable U V : Set. - Variable l : list U. - Variable f : { x : U | In x l } -> V. - - Obligations Tactic := unfold sub_list in * ; - program_simpl ; intuition. - - Program Fixpoint map_rec ( l' : list U | sub_list l' l ) - { measure length l' } : { r : list V | length r = length l' } := - match l' with - | nil => nil - | cons x tl => let tl' := map_rec tl in - f x :: tl' - end. - - Next Obligation. - destruct_call map_rec. - simpl in *. - subst l'. - simpl ; auto with arith. - Qed. - - Program Definition map : list V := map_rec l. - -End Map_DependentRecursor. - -Extraction map. -Extraction map_rec. - diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v deleted file mode 100644 index 05fc0803..00000000 --- a/contrib/subtac/test/ListsTest.v +++ /dev/null @@ -1,99 +0,0 @@ -(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) -Require Import Coq.Program.Program. -Require Import List. - -Set Implicit Arguments. - -Section Accessors. - Variable A : Set. - - Program Definition myhd : forall (l : list A | length l <> 0), A := - fun l => - match l with - | nil => ! - | hd :: tl => hd - end. - - Program Definition mytail (l : list A | length l <> 0) : list A := - match l with - | nil => ! - | hd :: tl => tl - end. -End Accessors. - -Program Definition test_hd : nat := myhd (cons 1 nil). - -(*Eval compute in test_hd*) -(*Program Definition test_tail : list A := mytail nil.*) - -Section app. - Variable A : Set. - - Program Fixpoint app (l : list A) (l' : list A) { struct l } : - { r : list A | length r = length l + length l' } := - match l with - | nil => l' - | hd :: tl => hd :: (tl ++ l') - end - where "x ++ y" := (app x y). - - Next Obligation. - intros. - destruct_call app ; program_simpl. - Defined. - - Program Lemma app_id_l : forall l : list A, l = nil ++ l. - Proof. - simpl ; auto. - Qed. - - Program Lemma app_id_r : forall l : list A, l = l ++ nil. - Proof. - induction l ; simpl in * ; auto. - rewrite <- IHl ; auto. - Qed. - -End app. - -Extraction app. - -Section Nth. - - Variable A : Set. - - Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := - match n, l with - | 0, hd :: _ => hd - | S n', _ :: tl => nth tl n' - | _, nil => ! - end. - - Next Obligation. - Proof. - simpl in *. auto with arith. - Defined. - - Next Obligation. - Proof. - inversion H. - Qed. - - Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := - match l, n with - | hd :: _, 0 => hd - | _ :: tl, S n' => nth' tl n' - | nil, _ => ! - end. - Next Obligation. - Proof. - simpl in *. auto with arith. - Defined. - - Next Obligation. - Proof. - intros. - inversion H. - Defined. - -End Nth. - diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v deleted file mode 100644 index ac49ca96..00000000 --- a/contrib/subtac/test/Mutind.v +++ /dev/null @@ -1,20 +0,0 @@ -Require Import List. - -Program Fixpoint f a : { x : nat | x > 0 } := - match a with - | 0 => 1 - | S a' => g a a' - end -with g a b : { x : nat | x > 0 } := - match b with - | 0 => 1 - | S b' => f b' - end. - -Check f. -Check g. - - - - - diff --git a/contrib/subtac/test/Test1.v b/contrib/subtac/test/Test1.v deleted file mode 100644 index 14b80854..00000000 --- a/contrib/subtac/test/Test1.v +++ /dev/null @@ -1,16 +0,0 @@ -Program Definition test (a b : nat) : { x : nat | x = a + b } := - ((a + b) : { x : nat | x = a + b }). -Proof. -intros. -reflexivity. -Qed. - -Print test. - -Require Import List. - -Program hd_opt (l : list nat) : { x : nat | x <> 0 } := - match l with - nil => 1 - | a :: l => a - end. diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v deleted file mode 100644 index 501aa798..00000000 --- a/contrib/subtac/test/euclid.v +++ /dev/null @@ -1,24 +0,0 @@ -Require Import Coq.Program.Program. -Require Import Coq.Arith.Compare_dec. -Notation "( x & y )" := (existS _ x y) : core_scope. - -Require Import Omega. - -Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} : - { q : nat & { r : nat | a = b * q + r /\ r < b } } := - if le_lt_dec b a then let (q', r) := euclid (a - b) b in - (S q' & r) - else (O & a). - -Next Obligation. - assert(b * S q' = b * q' + b) by auto with arith ; omega. -Defined. - -Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q). - -Eval lazy beta zeta delta iota in test_euclid. - -Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } := - (a & S a). - -Check testsig. diff --git a/contrib/subtac/test/id.v b/contrib/subtac/test/id.v deleted file mode 100644 index 9ae11088..00000000 --- a/contrib/subtac/test/id.v +++ /dev/null @@ -1,46 +0,0 @@ -Require Coq.Arith.Arith. - -Require Import Coq.subtac.Utils. -Program Fixpoint id (n : nat) : { x : nat | x = n } := - match n with - | O => O - | S p => S (id p) - end. -intros ; auto. - -pose (subset_simpl (id p)). -simpl in e. -unfold p0. -rewrite e. -auto. -Defined. - -Check id. -Print id. -Extraction id. - -Axiom le_gt_dec : forall n m, { n <= m } + { n > m }. -Require Import Omega. - -Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } := - if le_gt_dec n 0 then 0 - else S (id_if (pred n)). -intros. -auto with arith. -intros. -pose (subset_simpl (id_if (pred n))). -simpl in e. -rewrite e. -induction n ; auto with arith. -Defined. - -Print id_if_instance. -Extraction id_if_instance. - -Notation "( x & y )" := (@existS _ _ x y) : core_scope. - -Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} := - (a & a). -intros. -auto. -Qed. diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v deleted file mode 100644 index 4f938f4f..00000000 --- a/contrib/subtac/test/measure.v +++ /dev/null @@ -1,20 +0,0 @@ -Notation "( x & y )" := (@existS _ _ x y) : core_scope. -Unset Printing All. -Require Import Coq.Arith.Compare_dec. - -Require Import Coq.Program.Program. - -Fixpoint size (a : nat) : nat := - match a with - 0 => 1 - | S n => S (size n) - end. - -Program Fixpoint test_measure (a : nat) {measure size a} : nat := - match a with - | S (S n) => S (test_measure n) - | 0 | S 0 => a - end. - -Check test_measure. -Print test_measure.
\ No newline at end of file diff --git a/contrib/subtac/test/rec.v b/contrib/subtac/test/rec.v deleted file mode 100644 index aaefd8cc..00000000 --- a/contrib/subtac/test/rec.v +++ /dev/null @@ -1,65 +0,0 @@ -Require Import Coq.Arith.Arith. -Require Import Lt. -Require Import Omega. - -Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }. -(*Proof. - intros. - elim (le_lt_dec y x) ; intros ; auto with arith. -Defined. -*) -Require Import Coq.subtac.FixSub. -Require Import Wf_nat. - -Lemma preda_lt_a : forall a, 0 < a -> pred a < a. -auto with arith. -Qed. - -Program Fixpoint id_struct (a : nat) : nat := - match a with - 0 => 0 - | S n => S (id_struct n) - end. - -Check struct_rec. - - if (lt_ge_dec O a) - then S (wfrec (pred a)) - else O. - -Program Fixpoint wfrec (a : nat) { wf a lt } : nat := - if (lt_ge_dec O a) - then S (wfrec (pred a)) - else O. -intros. -apply preda_lt_a ; auto. - -Defined. - -Extraction wfrec. -Extraction Inline proj1_sig. -Extract Inductive bool => "bool" [ "true" "false" ]. -Extract Inductive sumbool => "bool" [ "true" "false" ]. -Extract Inlined Constant lt_ge_dec => "<". - -Extraction wfrec. -Extraction Inline lt_ge_dec le_lt_dec. -Extraction wfrec. - - -Program Fixpoint structrec (a : nat) { wf a lt } : nat := - match a with - S n => S (structrec n) - | 0 => 0 - end. -intros. -unfold n0. -omega. -Defined. - -Print structrec. -Extraction structrec. -Extraction structrec. - -Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a). -Print structrec_fun. diff --git a/contrib/subtac/test/take.v b/contrib/subtac/test/take.v deleted file mode 100644 index 2e17959c..00000000 --- a/contrib/subtac/test/take.v +++ /dev/null @@ -1,34 +0,0 @@ -(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) -Require Import JMeq. -Require Import List. -Require Import Program. - -Set Implicit Arguments. -Obligations Tactic := idtac. - -Print cons. - -Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } := - match n with - | 0 => nil - | S p => - match l with - | cons hd tl => let rest := take tl p in cons hd rest - | nil => ! - end - end. - -Require Import Omega. -Solve All Obligations. -Next Obligation. - destruct_call take ; program_simpl. -Defined. - -Next Obligation. - intros. - inversion H. -Defined. - - - - diff --git a/contrib/subtac/test/wf.v b/contrib/subtac/test/wf.v deleted file mode 100644 index 49fec2b8..00000000 --- a/contrib/subtac/test/wf.v +++ /dev/null @@ -1,48 +0,0 @@ -Notation "( x & y )" := (@existS _ _ x y) : core_scope. -Unset Printing All. -Require Import Coq.Arith.Compare_dec. - -Require Import Coq.subtac.Utils. - -Ltac one_simpl_hyp := - match goal with - | [H : (`exist _ _ _) = _ |- _] => simpl in H - | [H : _ = (`exist _ _ _) |- _] => simpl in H - | [H : (`exist _ _ _) < _ |- _] => simpl in H - | [H : _ < (`exist _ _ _) |- _] => simpl in H - | [H : (`exist _ _ _) <= _ |- _] => simpl in H - | [H : _ <= (`exist _ _ _) |- _] => simpl in H - | [H : (`exist _ _ _) > _ |- _] => simpl in H - | [H : _ > (`exist _ _ _) |- _] => simpl in H - | [H : (`exist _ _ _) >= _ |- _] => simpl in H - | [H : _ >= (`exist _ _ _) |- _] => simpl in H - end. - -Ltac one_simpl_subtac := - destruct_exists ; - repeat one_simpl_hyp ; simpl. - -Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl. - -Require Import Omega. -Require Import Wf_nat. - -Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : - { q : nat & { r : nat | a = b * q + r /\ r < b } } := - if le_lt_dec b a then let (q', r) := euclid (a - b) b in - (S q' & r) - else (O & a). -destruct b ; simpl_subtac. -omega. -simpl_subtac. -assert(x0 * S q' = x0 + x0 * q'). -rewrite <- mult_n_Sm. -omega. -rewrite H2 ; omega. -simpl_subtac. -split ; auto with arith. -omega. -apply lt_wf. -Defined. - -Check euclid_evars_proof.
\ No newline at end of file diff --git a/contrib/xml/COPYRIGHT b/contrib/xml/COPYRIGHT deleted file mode 100644 index c8d231fd..00000000 --- a/contrib/xml/COPYRIGHT +++ /dev/null @@ -1,25 +0,0 @@ -(******************************************************************************) -(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *) -(* Project Helm (http://helm.cs.unibo.it) *) -(* Project MoWGLI (http://mowgli.cs.unibo.it) *) -(* *) -(* Coq Exportation to XML *) -(* *) -(******************************************************************************) - -This Coq module has been developed by Claudio Sacerdoti Coen -<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI. - -Project HELM (for Hypertextual Electronic Library of Mathematics) is a -project developed at the Department of Computer Science, University of Bologna; -http://helm.cs.unibo.it - -Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces) -is a UE IST project that generalizes and extends the HELM project; -http://mowgli.cs.unibo.it - -The author is interested in any possible usage of the module. -So, if you plan to use the module, please send him an e-mail. - -The licensing policy applied to the module is the same as for the whole Coq -distribution. diff --git a/contrib/xml/README b/contrib/xml/README deleted file mode 100644 index a45dd31a..00000000 --- a/contrib/xml/README +++ /dev/null @@ -1,254 +0,0 @@ -(******************************************************************************) -(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *) -(* Project Helm (http://helm.cs.unibo.it) *) -(* Project MoWGLI (http://mowgli.cs.unibo.it) *) -(* *) -(* Coq Exportation to XML *) -(* *) -(******************************************************************************) - -This module provides commands to export a piece of Coq library in XML format. -Only the information relevant to proof-checking and proof-rendering is exported, -i.e. only the CIC proof objects (lambda-terms). - -This document is tructured in the following way: - 1. User documentation - 1.1. New vernacular commands available - 1.2. New coqc/coqtop flags and suggested usage - 1.3. How to exploit the XML files - 2. Technical informations - 2.1. Inner-types - 2.2. CIC with Explicit Named Substitutions - 2.3. The CIC with Explicit Named Substitutions XML DTD - -================================================================================ - USER DOCUMENTATION -================================================================================ - -======================================= -1.1. New vernacular commands available: -======================================= - -The new commands are: - - Print XML qualid. It prints in XML (to standard output) the - object whose qualified name is qualid and - its inner-types (see Sect. 2.1). - The inner-types are always printed - in their own XML file. If the object is a - constant, its type and body are also printed - as two distinct XML files. - The object printed is always the most - discharged form of the object (see - the Section command of the Coq manual). - - Print XML File "filename" qualid. Similar to "Print XML qualid". The generated - files are stored on the hard-disk using the - base file name "filename". - - Show XML Proof. It prints in XML the current proof in - progress. Its inner-types are also printed. - - Show XML File "filename" Proof. Similar to "Show XML Proof". The generated - files are stored on the hard-disk using - the base file name "filename". - - The verbosity of the previous commands is raised if the configuration - parameter verbose of xmlcommand.ml is set to true at compile time. - -============================================== -1.2. New coqc/coqtop flags and suggested usage -============================================== - - The following flag has been added to coqc and coqtop: - - -xml export XML files either to the hierarchy rooted in - the directory $COQ_XML_LIBRARY_ROOT (if the environment - variable is set) or to stdout (if unset) - - If the flag is set, every definition or declaration is immediately - exported to XML. The XML files describe the user-provided non-discharged - form of the definition or declaration. - - - The coq_makefile utility has also been modified to easily allow XML - exportation: - - make COQ_XML=-xml (or, equivalently, setting the environment - variable COQ_XML) - - - The suggested usage of the module is the following: - - 1. add to your own contribution a valid Make file and use coq_makefile - to generate the Makefile from the Make file. - *WARNING:* Since logical names are used to structure the XML hierarchy, - always add to the Make file at least one "-R" option to map physical - file names to logical module paths. See the Coq manual for further - informations on the -R flag. - 2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy - must be physically rooted. - 3. compile your contribution with "make COQ_XML=-xml" - - -================================= -1.3. How to exploit the XML files -================================= - - Once the information is exported to XML, it becomes possible to implement - services that are completely Coq-independent. Projects HELM and MoWGLI - already provide rendering, searching and data mining functionalities. - - In particular, the standard library and contributions of Coq can be - browsed and searched on the HELM web site: - - http://helm.cs.unibo.it/library.html - - - If you want to publish your own contribution so that it is included in the - HELM library, use the MoWGLI prototype upload form: - - http://mowgli.cs.unibo.it - - -================================================================================ - TECHNICAL INFORMATIONS -================================================================================ - -========================== -2.1. Inner-types -========================== - -In order to do proof-rendering (for example in natural language), -some redundant typing information is required, i.e. the type of -at least some of the subterms of the bodies and types. So, each -new command described in section 1.1 print not only -the object, but also another XML file in which you can find -the type of all the subterms of the terms of the printed object -which respect the following conditions: - - 1. It's sort is Prop or CProp (the "sort"-like definition used in - CoRN to type computationally relevant predicative propositions). - 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL, - VAR, MUTCONSTR or CONST. - 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA, - i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is - printed. - -The rationale for the 3rd condition is that the type of the inner LAMBDAs -could be easily computed starting from the type of the outer LAMBDA; moreover, -the types of the inner LAMBDAs requires a lot of disk/memory space: removing -the 3rd condition leads to XML file that are two times as big as the ones -exported appling the 3rd condition. - -========================================== -2.2. CIC with Explicit Named Substitutions -========================================== - -The exported files are and XML encoding of the lambda-terms used by the -Coq system. The implementative details of the Coq system are hidden as much -as possible, so that the XML DTD is a straightforward encoding of the -Calculus of (Co)Inductive Constructions. - -Nevertheless, there is a feature of the Coq system that can not be -hidden in a completely satisfactory way: discharging. In Coq it is possible -to open a section, declare variables and use them in the rest of the section -as if they were axiom declarations. Once the section is closed, every definition -and theorem in the section is discharged by abstracting it over the section -variables. Variable declarations as well as section declarations are entirely -dropped. Since we are interested in an XML encoding of definitions and -theorems as close as possible to those directly provided the user, we -do not want to export discharged forms. Exporting non-discharged theorem -and definitions together with theorems that rely on the discharged forms -obliges the tools that work on the XML encoding to implement discharging to -achieve logical consistency. Moreover, the rendering of the files can be -misleading, since hyperlinks can be shown between occurrences of the discharge -form of a definition and the non-discharged definition, that are different -objects. - -To overcome the previous limitations, Claudio Sacerdoti Coen developed in his -PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions -with Explicit Named Substitutions, that is a slight extension of CIC where -discharging is not necessary. The DTD of the exported XML files describes -constants, inductive types and variables of the Calculus of (Co)Inductive -Constructions with Explicit Named Substitions. The conversion to the new -calculus is performed during the exportation phase. - -The following example shows a very small Coq development together with its -version in CIC with Explicit Named Substitutions. - -# CIC version: # -Section S. - Variable A : Prop. - - Definition impl := A -> A. - - Theorem t : impl. (* uses the undischarged form of impl *) - Proof. - exact (fun (a:A) => a). - Qed. - -End S. - -Theorem t' : (impl False). (* uses the discharged form of impl *) - Proof. - exact (t False). (* uses the discharged form of t *) - Qed. - -# Corresponding CIC with Explicit Named Substitutions version: # -Section S. - Variable A : Prop. - - Definition impl(A) := A -> A. (* theorems and definitions are - explicitly abstracted over the - variables. The name is sufficient - to completely describe the abstraction *) - - Theorem t(A) : impl. (* impl where A is not instantiated *) - Proof. - exact (fun (a:A) => a). - Qed. - -End S. - -Theorem t'() : impl{False/A}. (* impl where A is instantiated with False - Notice that t' does not depend on A *) - Proof. - exact t{False/A}. (* t where A is instantiated with False *) - Qed. - -Further details on the typing and reduction rules of the calculus can be -found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency -of the calculus is also proved. - -====================================================== -2.3. The CIC with Explicit Named Substitutions XML DTD -====================================================== - -A copy of the DTD can be found in the file "cic.dtd". - -<ConstantType> is the root element of the files that correspond to - constant types. -<ConstantBody> is the root element of the files that correspond to - constant bodies. It is used only for closed definitions and - theorems (i.e. when no metavariable occurs in the body - or type of the constant) -<CurrentProof> is the root element of the file that correspond to - the body of a constant that depends on metavariables - (e.g. unfinished proofs) -<Variable> is the root element of the files that correspond to variables -<InductiveTypes> is the root element of the files that correspond to blocks - of mutually defined inductive definitions - -The elements - <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>, - <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX> -are used to encode the constructors of CIC. The sort or type attribute of the -element, if present, is respectively the sort or the type of the term, that -is a sort because of the typing rules of CIC. - -The element <instantiate> correspond to the application of an explicit named -substitution to its first argument, that is a reference to a definition -or declaration in the environment. - -All the other elements are just syntactic sugar. diff --git a/contrib/xml/acic.ml b/contrib/xml/acic.ml deleted file mode 100644 index 032ddbeb..00000000 --- a/contrib/xml/acic.ml +++ /dev/null @@ -1,108 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -open Names -open Term - -(* Maps fron \em{unshared} [constr] to ['a]. *) -module CicHash = - Hashtbl.Make - (struct - type t = Term.constr - let equal = (==) - let hash = Hashtbl.hash - end) -;; - -type id = string (* the type of the (annotated) node identifiers *) -type uri = string - -type 'constr context_entry = - Decl of 'constr (* Declaration *) - | Def of 'constr * 'constr (* Definition; the second argument (the type) *) - (* is not present in the DTD, but is needed *) - (* to use Coq functions during exportation. *) - -type 'constr hypothesis = identifier * 'constr context_entry -type context = constr hypothesis list - -type conjecture = existential_key * context * constr -type metasenv = conjecture list - -(* list of couples section path -- variables defined in that section *) -type params = (string * uri list) list - -type obj = - Constant of string * (* id, *) - constr option * constr * (* value, type, *) - params (* parameters *) - | Variable of - string * constr option * constr * (* name, body, type *) - params (* parameters *) - | CurrentProof of - string * metasenv * (* name, conjectures, *) - constr * constr (* value, type *) - | InductiveDefinition of - inductiveType list * (* inductive types , *) - params * int (* parameters,n ind. pars*) -and inductiveType = - identifier * bool * constr * (* typename, inductive, arity *) - constructor list (* constructors *) -and constructor = - identifier * constr (* id, type *) - -type aconstr = - | ARel of id * int * id * identifier - | AVar of id * uri - | AEvar of id * existential_key * aconstr list - | ASort of id * sorts - | ACast of id * aconstr * aconstr - | AProds of (id * name * aconstr) list * aconstr - | ALambdas of (id * name * aconstr) list * aconstr - | ALetIns of (id * name * aconstr) list * aconstr - | AApp of id * aconstr list - | AConst of id * explicit_named_substitution * uri - | AInd of id * explicit_named_substitution * uri * int - | AConstruct of id * explicit_named_substitution * uri * int * int - | ACase of id * uri * int * aconstr * aconstr * aconstr list - | AFix of id * int * ainductivefun list - | ACoFix of id * int * acoinductivefun list -and ainductivefun = - id * identifier * int * aconstr * aconstr -and acoinductivefun = - id * identifier * aconstr * aconstr -and explicit_named_substitution = id option * (uri * aconstr) list - -type acontext = (id * aconstr hypothesis) list -type aconjecture = id * existential_key * acontext * aconstr -type ametasenv = aconjecture list - -type aobj = - AConstant of id * string * (* id, *) - aconstr option * aconstr * (* value, type, *) - params (* parameters *) - | AVariable of id * - string * aconstr option * aconstr * (* name, body, type *) - params (* parameters *) - | ACurrentProof of id * - string * ametasenv * (* name, conjectures, *) - aconstr * aconstr (* value, type *) - | AInductiveDefinition of id * - anninductiveType list * (* inductive types , *) - params * int (* parameters,n ind. pars*) -and anninductiveType = - id * identifier * bool * aconstr * (* typename, inductive, arity *) - annconstructor list (* constructors *) -and annconstructor = - identifier * aconstr (* id, type *) diff --git a/contrib/xml/acic2Xml.ml4 b/contrib/xml/acic2Xml.ml4 deleted file mode 100644 index 64dc8a05..00000000 --- a/contrib/xml/acic2Xml.ml4 +++ /dev/null @@ -1,363 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(*CSC codice cut & paste da cicPp e xmlcommand *) - -exception ImpossiblePossible;; -exception NotImplemented;; -let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";; -let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";; - -let rec find_last_id = - function - [] -> Util.anomaly "find_last_id: empty list" - | [id,_,_] -> id - | _::tl -> find_last_id tl -;; - -let export_existential = string_of_int - -let print_term ids_to_inner_sorts = - let rec aux = - let module A = Acic in - let module N = Names in - let module X = Xml in - function - A.ARel (id,n,idref,b) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_empty "REL" - ["value",(string_of_int n) ; "binder",(N.string_of_id b) ; - "id",id ; "idref",idref; "sort",sort] - | A.AVar (id,uri) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] - | A.AEvar (id,n,l) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "META" - ["no",(export_existential n) ; "id",id ; "sort",sort] - (List.fold_left - (fun i t -> - [< i ; X.xml_nempty "substitution" [] (aux t) >] - ) [< >] (List.rev l)) - | A.ASort (id,s) -> - let string_of_sort = - match Term.family_of_sort s with - Term.InProp -> "Prop" - | Term.InSet -> "Set" - | Term.InType -> "Type" - in - X.xml_empty "SORT" ["value",string_of_sort ; "id",id] - | A.AProds (prods,t) -> - let last_id = find_last_id prods in - let sort = Hashtbl.find ids_to_inner_sorts last_id in - X.xml_nempty "PROD" ["type",sort] - [< List.fold_left - (fun i (id,binder,s) -> - let sort = - Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) - in - let attrs = - ("id",id)::("type",sort):: - match binder with - Names.Anonymous -> [] - | Names.Name b -> ["binder",Names.string_of_id b] - in - [< X.xml_nempty "decl" attrs (aux s) ; i >] - ) [< >] prods ; - X.xml_nempty "target" [] (aux t) - >] - | A.ACast (id,v,t) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "CAST" ["id",id ; "sort",sort] - [< X.xml_nempty "term" [] (aux v) ; - X.xml_nempty "type" [] (aux t) - >] - | A.ALambdas (lambdas,t) -> - let last_id = find_last_id lambdas in - let sort = Hashtbl.find ids_to_inner_sorts last_id in - X.xml_nempty "LAMBDA" ["sort",sort] - [< List.fold_left - (fun i (id,binder,s) -> - let sort = - Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) - in - let attrs = - ("id",id)::("type",sort):: - match binder with - Names.Anonymous -> [] - | Names.Name b -> ["binder",Names.string_of_id b] - in - [< X.xml_nempty "decl" attrs (aux s) ; i >] - ) [< >] lambdas ; - X.xml_nempty "target" [] (aux t) - >] - | A.ALetIns (letins,t) -> - let last_id = find_last_id letins in - let sort = Hashtbl.find ids_to_inner_sorts last_id in - X.xml_nempty "LETIN" ["sort",sort] - [< List.fold_left - (fun i (id,binder,s) -> - let sort = - Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) - in - let attrs = - ("id",id)::("sort",sort):: - match binder with - Names.Anonymous -> assert false - | Names.Name b -> ["binder",Names.string_of_id b] - in - [< X.xml_nempty "def" attrs (aux s) ; i >] - ) [< >] letins ; - X.xml_nempty "target" [] (aux t) - >] - | A.AApp (id,li) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "APPLY" ["id",id ; "sort",sort] - [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li) - >] - | A.AConst (id,subst,uri) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - let attrs = ["uri", uri ; "id",id ; "sort",sort] in - aux_subst (X.xml_empty "CONST" attrs) subst - | A.AInd (id,subst,uri,i) -> - let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in - aux_subst (X.xml_empty "MUTIND" attrs) subst - | A.AConstruct (id,subst,uri,i,j) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - let attrs = - ["uri", uri ; - "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; - "id",id ; "sort",sort] - in - aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst - | A.ACase (id,uri,typeno,ty,te,patterns) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "MUTCASE" - ["uriType", uri ; - "noType", (string_of_int typeno) ; - "id", id ; "sort",sort] - [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; - X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; - List.fold_left - (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >]) - [<>] patterns - >] - | A.AFix (id, no, funs) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "FIX" - ["noFun", (string_of_int no) ; "id",id ; "sort",sort] - [< List.fold_left - (fun i (id,fi,ai,ti,bi) -> - [< i ; - X.xml_nempty "FixFunction" - ["id",id ; "name", (Names.string_of_id fi) ; - "recIndex", (string_of_int ai)] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] - >] - ) [<>] funs - >] - | A.ACoFix (id,no,funs) -> - let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "COFIX" - ["noFun", (string_of_int no) ; "id",id ; "sort",sort] - [< List.fold_left - (fun i (id,fi,ti,bi) -> - [< i ; - X.xml_nempty "CofixFunction" - ["id",id ; "name", Names.string_of_id fi] - [< X.xml_nempty "type" [] [< aux ti >] ; - X.xml_nempty "body" [] [< aux bi >] - >] - >] - ) [<>] funs - >] - and aux_subst target (id,subst) = - if subst = [] then - target - else - Xml.xml_nempty "instantiate" - (match id with None -> [] | Some id -> ["id",id]) - [< target ; - List.fold_left - (fun i (uri,arg) -> - [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >] - ) [<>] subst - >] - in - aux -;; - -let param_attribute_of_params params = - List.fold_right - (fun (path,l) i -> - List.fold_right - (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i' - ) l "" ^ match i with "" -> "" | i' -> " " ^ i' - ) params "" -;; - -let print_object uri ids_to_inner_sorts = - let rec aux = - let module A = Acic in - let module X = Xml in - function - A.ACurrentProof (id,n,conjectures,bo,ty) -> - let xml_for_current_proof_body = -(*CSC: Should the CurrentProof also have the list of variables it depends on? *) -(*CSC: I think so. Not implemented yet. *) - X.xml_nempty "CurrentProof" ["of",uri ; "id", id] - [< List.fold_left - (fun i (cid,n,canonical_context,t) -> - [< i ; - X.xml_nempty "Conjecture" - ["id", cid ; "no",export_existential n] - [< List.fold_left - (fun i (hid,t) -> - [< (match t with - n,A.Decl t -> - X.xml_nempty "Decl" - ["id",hid;"name",Names.string_of_id n] - (print_term ids_to_inner_sorts t) - | n,A.Def (t,_) -> - X.xml_nempty "Def" - ["id",hid;"name",Names.string_of_id n] - (print_term ids_to_inner_sorts t) - ) ; - i - >] - ) [< >] canonical_context ; - X.xml_nempty "Goal" [] - (print_term ids_to_inner_sorts t) - >] - >]) - [<>] (List.rev conjectures) ; - X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >] - in - let xml_for_current_proof_type = - X.xml_nempty "ConstantType" ["name",n ; "id", id] - (print_term ids_to_inner_sorts ty) - in - let xmlbo = - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n"); - xml_for_current_proof_body - >] in - let xmlty = - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata - ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n"); - xml_for_current_proof_type - >] - in - xmlty, Some xmlbo - | A.AConstant (id,n,bo,ty,params) -> - let params' = param_attribute_of_params params in - let xmlbo = - match bo with - None -> None - | Some bo -> - Some - [< X.xml_cdata - "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata - ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ; - X.xml_nempty "ConstantBody" - ["for",uri ; "params",params' ; "id", id] - [< print_term ids_to_inner_sorts bo >] - >] - in - let xmlty = - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n"); - X.xml_nempty "ConstantType" - ["name",n ; "params",params' ; "id", id] - [< print_term ids_to_inner_sorts ty >] - >] - in - xmlty, xmlbo - | A.AVariable (id,n,bo,ty,params) -> - let params' = param_attribute_of_params params in - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ; - X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id] - [< (match bo with - None -> [<>] - | Some bo -> - X.xml_nempty "body" [] - (print_term ids_to_inner_sorts bo) - ) ; - X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty) - >] - >], None - | A.AInductiveDefinition (id,tys,params,nparams) -> - let params' = param_attribute_of_params params in - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ - dtdname ^ "\">\n") ; - X.xml_nempty "InductiveDefinition" - ["noParams",string_of_int nparams ; - "id",id ; - "params",params'] - [< (List.fold_left - (fun i (id,typename,finite,arity,cons) -> - [< i ; - X.xml_nempty "InductiveType" - ["id",id ; "name",Names.string_of_id typename ; - "inductive",(string_of_bool finite) - ] - [< X.xml_nempty "arity" [] - (print_term ids_to_inner_sorts arity) ; - (List.fold_left - (fun i (name,lc) -> - [< i ; - X.xml_nempty "Constructor" - ["name",Names.string_of_id name] - (print_term ids_to_inner_sorts lc) - >]) [<>] cons - ) - >] - >] - ) [< >] tys - ) - >] - >], None - in - aux -;; - -let print_inner_types curi ids_to_inner_sorts ids_to_inner_types = - let module C2A = Cic2acic in - let module X = Xml in - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n"); - X.xml_nempty "InnerTypes" ["of",curi] - (Hashtbl.fold - (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> - [< x ; - X.xml_nempty "TYPE" ["of",id] - [< X.xml_nempty "synthesized" [] - (print_term ids_to_inner_sorts synty) ; - match expty with - None -> [<>] - | Some expty' -> - X.xml_nempty "expected" [] - (print_term ids_to_inner_sorts expty') - >] - >] - ) ids_to_inner_types [<>] - ) - >] -;; diff --git a/contrib/xml/cic.dtd b/contrib/xml/cic.dtd deleted file mode 100644 index c8035cab..00000000 --- a/contrib/xml/cic.dtd +++ /dev/null @@ -1,259 +0,0 @@ -<?xml encoding="ISO-8859-1"?> - -<!-- Copyright (C) 2000-2004, HELM Team --> -<!-- --> -<!-- This file is part of HELM, an Hypertextual, Electronic --> -<!-- Library of Mathematics, developed at the Computer Science --> -<!-- Department, University of Bologna, Italy. --> -<!-- --> -<!-- HELM is free software; you can redistribute it and/or --> -<!-- modify it under the terms of the GNU General Public License --> -<!-- as published by the Free Software Foundation; either version 2 --> -<!-- of the License, or (at your option) any later version. --> -<!-- --> -<!-- HELM is distributed in the hope that it will be useful, --> -<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of --> -<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --> -<!-- GNU General Public License for more details. --> -<!-- --> -<!-- You should have received a copy of the GNU General Public License --> -<!-- along with HELM; if not, write to the Free Software --> -<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, --> -<!-- MA 02111-1307, USA. --> -<!-- --> -<!-- For details, see the HELM World-Wide-Web page, --> -<!-- http://cs.unibo.it/helm/. --> - -<!-- DTD FOR CIC OBJECTS: --> - -<!-- CIC term declaration --> - -<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST| - LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'> - -<!-- CIC sorts --> - -<!ENTITY % sort '(Prop|Set|Type|CProp)'> - -<!-- CIC sequents --> - -<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'> - -<!-- CIC objects: --> - -<!ELEMENT ConstantType %term;> -<!ATTLIST ConstantType - name CDATA #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT ConstantBody %term;> -<!ATTLIST ConstantBody - for CDATA #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT CurrentProof (Conjecture*,body)> -<!ATTLIST CurrentProof - of CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT InductiveDefinition (InductiveType+)> -<!ATTLIST InductiveDefinition - noParams NMTOKEN #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Variable (body?,type)> -<!ATTLIST Variable - name CDATA #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Sequent %sequent;> -<!ATTLIST Sequent - no NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!-- Elements used in CIC objects, which are not terms: --> - -<!ELEMENT InductiveType (arity,Constructor*)> -<!ATTLIST InductiveType - name CDATA #REQUIRED - inductive (true|false) #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Conjecture %sequent;> -<!ATTLIST Conjecture - no NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Constructor %term;> -<!ATTLIST Constructor - name CDATA #REQUIRED> - -<!ELEMENT Decl %term;> -<!ATTLIST Decl - name CDATA #IMPLIED - id ID #REQUIRED> - -<!ELEMENT Def %term;> -<!ATTLIST Def - name CDATA #IMPLIED - id ID #REQUIRED> - -<!ELEMENT Hidden EMPTY> -<!ATTLIST Hidden - id ID #REQUIRED> - -<!ELEMENT Goal %term;> - -<!-- CIC terms: --> - -<!ELEMENT LAMBDA (decl*,target)> -<!ATTLIST LAMBDA - sort %sort; #REQUIRED> - -<!ELEMENT LETIN (def*,target)> -<!ATTLIST LETIN - sort %sort; #REQUIRED> - -<!ELEMENT PROD (decl*,target)> -<!ATTLIST PROD - type %sort; #REQUIRED> - -<!ELEMENT CAST (term,type)> -<!ATTLIST CAST - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT REL EMPTY> -<!ATTLIST REL - value NMTOKEN #REQUIRED - binder CDATA #REQUIRED - id ID #REQUIRED - idref IDREF #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT SORT EMPTY> -<!ATTLIST SORT - value CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT APPLY (%term;)+> -<!ATTLIST APPLY - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT VAR EMPTY> -<!ATTLIST VAR - uri CDATA #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!-- The substitutions are ordered by increasing DeBrujin --> -<!-- index. An empty substitution means that that index is --> -<!-- not accessible. --> -<!ELEMENT META (substitution*)> -<!ATTLIST META - no NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT IMPLICIT EMPTY> -<!ATTLIST IMPLICIT - id ID #REQUIRED> - -<!ELEMENT CONST EMPTY> -<!ATTLIST CONST - uri CDATA #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT MUTIND EMPTY> -<!ATTLIST MUTIND - uri CDATA #REQUIRED - noType NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!ELEMENT MUTCONSTRUCT EMPTY> -<!ATTLIST MUTCONSTRUCT - uri CDATA #REQUIRED - noType NMTOKEN #REQUIRED - noConstr NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)> -<!ATTLIST MUTCASE - uriType CDATA #REQUIRED - noType NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT FIX (FixFunction+)> -<!ATTLIST FIX - noFun NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT COFIX (CofixFunction+)> -<!ATTLIST COFIX - noFun NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!-- Elements used in CIC terms: --> - -<!ELEMENT FixFunction (type,body)> -<!ATTLIST FixFunction - name CDATA #REQUIRED - id ID #REQUIRED - recIndex NMTOKEN #REQUIRED> - -<!ELEMENT CofixFunction (type,body)> -<!ATTLIST CofixFunction - id ID #REQUIRED - name CDATA #REQUIRED> - -<!ELEMENT substitution ((%term;)?)> - -<!-- Explicit named substitutions: --> - -<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)> -<!ATTLIST instantiate - id ID #IMPLIED> - -<!-- Sintactic sugar for CIC terms and for CIC objects: --> - -<!ELEMENT arg %term;> -<!ATTLIST arg - relUri CDATA #REQUIRED> - -<!ELEMENT decl %term;> -<!ATTLIST decl - id ID #REQUIRED - type %sort; #REQUIRED - binder CDATA #IMPLIED> - -<!ELEMENT def %term;> -<!ATTLIST def - id ID #REQUIRED - sort %sort; #REQUIRED - binder CDATA #IMPLIED> - -<!ELEMENT target %term;> - -<!ELEMENT term %term;> - -<!ELEMENT type %term;> - -<!ELEMENT arity %term;> - -<!ELEMENT patternsType %term;> - -<!ELEMENT inductiveTerm %term;> - -<!ELEMENT pattern %term;> - -<!ELEMENT body %term;> diff --git a/contrib/xml/cic2Xml.ml b/contrib/xml/cic2Xml.ml deleted file mode 100644 index 08d3a850..00000000 --- a/contrib/xml/cic2Xml.ml +++ /dev/null @@ -1,17 +0,0 @@ -let print_xml_term ch env sigma cic = - let ids_to_terms = Hashtbl.create 503 in - let constr_to_ids = Acic.CicHash.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let seed = ref 0 in - let acic = - Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - env [] sigma (Unshare.unshare cic) None in - let xml = Acic2Xml.print_term ids_to_inner_sorts acic in - Xml.pp_ch xml ch -;; - -Tacinterp.declare_xml_printer print_xml_term -;; diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml deleted file mode 100644 index 13e5e6d5..00000000 --- a/contrib/xml/cic2acic.ml +++ /dev/null @@ -1,974 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(* Utility Functions *) - -exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;; -let get_module_path_of_section_path path = - let dirpath = fst (Libnames.repr_path path) in - let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in - match - List.filter - (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules - with - [] -> - Pp.warning ("Modules not supported: reference to "^ - Libnames.string_of_path path^" will be wrong"); - dirpath - | [modul] -> modul - | _ -> - raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther -;; - -(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *) -(*CSC: not exist two modules whose dir_paths are one a prefix of the other *) -let remove_module_dirpath_from_dirpath ~basedir dir = - let module Ln = Libnames in - if Ln.is_dirpath_prefix_of basedir dir then - let ids = Names.repr_dirpath dir in - let rec remove_firsts n l = - match n,l with - (0,l) -> l - | (n,he::tl) -> remove_firsts (n-1) tl - | _ -> assert false - in - let ids' = - List.rev - (remove_firsts - (List.length (Names.repr_dirpath basedir)) - (List.rev ids)) - in - ids' - else Names.repr_dirpath dir -;; - - -let get_uri_of_var v pvars = - let module D = Decls in - let module N = Names in - let rec search_in_open_sections = - function - [] -> Util.error ("Variable "^v^" not found") - | he::tl as modules -> - let dirpath = N.make_dirpath modules in - if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then - modules - else - search_in_open_sections tl - in - let path = - if List.mem v pvars then - [] - else - search_in_open_sections (N.repr_dirpath (Lib.cwd ())) - in - "cic:" ^ - List.fold_left - (fun i x -> "/" ^ N.string_of_id x ^ i) "" path -;; - -type tag = - Constant of Names.constant - | Inductive of Names.kernel_name - | Variable of Names.kernel_name -;; - -type etag = - TConstant - | TInductive - | TVariable -;; - -let etag_of_tag = - function - Constant _ -> TConstant - | Inductive _ -> TInductive - | Variable _ -> TVariable - -let ext_of_tag = - function - TConstant -> "con" - | TInductive -> "ind" - | TVariable -> "var" -;; - -exception FunctorsXMLExportationNotImplementedYet;; - -let subtract l1 l2 = - let l1' = List.rev (Names.repr_dirpath l1) in - let l2' = List.rev (Names.repr_dirpath l2) in - let rec aux = - function - he::tl when tl = l2' -> [he] - | he::tl -> he::(aux tl) - | [] -> assert (l2' = []) ; [] - in - Names.make_dirpath (List.rev (aux l1')) -;; - -(*CSC: Dead code to be removed -let token_list_of_kernel_name ~keep_sections kn tag = - let module N = Names in - let (modpath,dirpath,label) = Names.repr_kn kn in - let token_list_of_dirpath dirpath = - List.rev_map N.string_of_id (N.repr_dirpath dirpath) in - let rec token_list_of_modpath = - function - N.MPdot (path,label) -> - token_list_of_modpath path @ [N.string_of_label label] - | N.MPfile dirpath -> token_list_of_dirpath dirpath - | N.MPself self -> - if self = Names.initial_msid then - [ "Top" ] - else - let module_path = - let f = N.string_of_id (N.id_of_msid self) in - let _,longf = - System.find_file_in_path (Library.get_load_path ()) (f^".v") in - let ldir0 = Library.find_logical_path (Filename.dirname longf) in - let id = Names.id_of_string (Filename.basename f) in - Libnames.extend_dirpath ldir0 id - in - token_list_of_dirpath module_path - | N.MPbound _ -> raise FunctorsXMLExportationNotImplementedYet - in - token_list_of_modpath modpath @ - (if keep_sections then token_list_of_dirpath dirpath else []) @ - [N.string_of_label label ^ "." ^ (ext_of_tag tag)] -;; -*) - -let token_list_of_path dir id tag = - let module N = Names in - let token_list_of_dirpath dirpath = - List.rev_map N.string_of_id (N.repr_dirpath dirpath) in - token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)] - -let token_list_of_kernel_name tag = - let module N = Names in - let module LN = Libnames in - let id,dir = match tag with - | Variable kn -> - N.id_of_label (N.label kn), Lib.cwd () - | Constant con -> - N.id_of_label (N.con_label con), - Lib.remove_section_part (LN.ConstRef con) - | Inductive kn -> - N.id_of_label (N.label kn), - Lib.remove_section_part (LN.IndRef (kn,0)) - in - token_list_of_path dir id (etag_of_tag tag) -;; - -let uri_of_kernel_name tag = - let tokens = token_list_of_kernel_name tag in - "cic:/" ^ String.concat "/" tokens - -let uri_of_declaration id tag = - let module LN = Libnames in - let dir = LN.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) in - let tokens = token_list_of_path dir id tag in - "cic:/" ^ String.concat "/" tokens - -(* Special functions for handling of CCorn's CProp "sort" *) - -type sort = - Coq_sort of Term.sorts_family - | CProp -;; - -let prerr_endline _ = ();; - -let family_of_term ty = - match Term.kind_of_term ty with - Term.Sort s -> Coq_sort (Term.family_of_sort s) - | Term.Const _ -> CProp (* I could check that the constant is CProp *) - | _ -> Util.anomaly "family_of_term" -;; - -module CPropRetyping = - struct - module T = Term - - let outsort env sigma t = - family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t) - - let rec subst_type env sigma typ = function - | [] -> typ - | h::rest -> - match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with - | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest - | _ -> Util.anomaly "Non-functional construction" - - - let sort_of_atomic_type env sigma ft args = - let rec concl_of_arity env ar = - match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with - | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b - | T.Sort s -> Coq_sort (T.family_of_sort s) - | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) - in concl_of_arity env ft - -let typeur sigma metamap = - let rec type_of env cstr= - match Term.kind_of_term cstr with - | T.Meta n -> - (try T.strip_outer_cast (List.assoc n metamap) - with Not_found -> Util.anomaly "type_of: this is not a well-typed term") - | T.Rel n -> - let (_,_,ty) = Environ.lookup_rel n env in - T.lift n ty - | T.Var id -> - (try - let (_,_,ty) = Environ.lookup_named id env in - ty - with Not_found -> - Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) - | T.Const c -> - let cb = Environ.lookup_constant c env in - Typeops.type_of_constant_type env (cb.Declarations.const_type) - | T.Evar ev -> Evd.existential_type sigma ev - | T.Ind ind -> Inductiveops.type_of_inductive env ind - | T.Construct cstr -> Inductiveops.type_of_constructor env cstr - | T.Case (_,p,c,lf) -> - let Inductiveops.IndType(_,realargs) = - try Inductiveops.find_rectype env sigma (type_of env c) - with Not_found -> Util.anomaly "type_of: Bad recursive type" in - let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in - (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with - | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c])) - | _ -> t) - | T.Lambda (name,c1,c2) -> - T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2) - | T.LetIn (name,b,c1,c2) -> - T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2) - | T.Fix ((_,i),(_,tys,_)) -> tys.(i) - | T.CoFix (i,(_,tys,_)) -> tys.(i) - | T.App(f,args)-> - T.strip_outer_cast - (subst_type env sigma (type_of env f) (Array.to_list args)) - | T.Cast (c,_, t) -> t - | T.Sort _ | T.Prod _ -> - match sort_of env cstr with - Coq_sort T.InProp -> T.mkProp - | Coq_sort T.InSet -> T.mkSet - | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) - | CProp -> T.mkConst DoubleTypeInference.cprop - - and sort_of env t = - match Term.kind_of_term t with - | T.Cast (c,_, s) when T.isSort s -> family_of_term s - | T.Sort (T.Prop c) -> Coq_sort T.InType - | T.Sort (T.Type u) -> Coq_sort T.InType - | T.Prod (name,t,c2) -> - (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with - | _, (Coq_sort T.InProp as s) -> s - | Coq_sort T.InProp, (Coq_sort T.InSet as s) - | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s - | Coq_sort T.InType, (Coq_sort T.InSet as s) - | CProp, (Coq_sort T.InSet as s) when - Environ.engagement env = Some Declarations.ImpredicativeSet -> s - | Coq_sort T.InType, Coq_sort T.InSet - | CProp, Coq_sort T.InSet -> Coq_sort T.InType - | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*) - | _, (CProp as s) -> s) - | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args - | T.Lambda _ | T.Fix _ | T.Construct _ -> - Util.anomaly "sort_of: Not a type (1)" - | _ -> outsort env sigma (type_of env t) - - and sort_family_of env t = - match T.kind_of_term t with - | T.Cast (c,_, s) when T.isSort s -> family_of_term s - | T.Sort (T.Prop c) -> Coq_sort T.InType - | T.Sort (T.Type u) -> Coq_sort T.InType - | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2 - | T.App(f,args) -> - sort_of_atomic_type env sigma (type_of env f) args - | T.Lambda _ | T.Fix _ | T.Construct _ -> - Util.anomaly "sort_of: Not a type (1)" - | _ -> outsort env sigma (type_of env t) - - in type_of, sort_of, sort_family_of - - let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c - let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c - - end -;; - -let get_sort_family_of env evar_map ty = - CPropRetyping.get_sort_family_of env evar_map ty -;; - -let type_as_sort env evar_map ty = -(* CCorn code *) - family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty) -;; - -let is_a_Prop = - function - "Prop" - | "CProp" -> true - | _ -> false -;; - -(* Main Functions *) - -type anntypes = - {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option} -;; - -let gen_id seed = - let res = "i" ^ string_of_int !seed in - incr seed ; - res -;; - -let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids = - fun father t -> - let res = gen_id seed in - Hashtbl.add ids_to_father_ids res father ; - Hashtbl.add ids_to_terms res t ; - Acic.CicHash.add constr_to_ids t res ; - res -;; - -let source_id_of_id id = "#source#" ^ id;; - -let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types - ?(fake_dependent_products=false) env idrefs evar_map t expectedty -= - let module D = DoubleTypeInference in - let module E = Environ in - let module N = Names in - let module A = Acic in - let module T = Term in - let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in - (* CSC: do you have any reasonable substitute for 503? *) - let terms_to_types = Acic.CicHash.create 503 in - D.double_type_of env evar_map t expectedty terms_to_types ; - let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env - idrefs ?(subst=None,[]) tt - = - let fresh_id'' = fresh_id' father tt in - let aux' = aux computeinnertypes (Some fresh_id'') [] in - let string_of_sort_family = - function - Coq_sort T.InProp -> "Prop" - | Coq_sort T.InSet -> "Set" - | Coq_sort T.InType -> "Type" - | CProp -> "CProp" - in - let string_of_sort t = - string_of_sort_family - (type_as_sort env evar_map t) - in - let ainnertypes,innertype,innersort,expected_available = - let {D.synthesized = synthesized; D.expected = expected} = - if computeinnertypes then -try - Acic.CicHash.find terms_to_types tt -with _ -> -(*CSC: Warning: it really happens, for example in Ring_theory!!! *) -Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false - else - (* We are already in an inner-type and Coscoy's double *) - (* type inference algorithm has not been applied. *) - (* We need to refresh the universes because we are doing *) - (* type inference on an already inferred type. *) - {D.synthesized = - Reductionops.nf_beta evar_map - (CPropRetyping.get_type_of env evar_map - (Termops.refresh_universes tt)) ; - D.expected = None} - in -(* Debugging only: -print_endline "TERMINE:" ; flush stdout ; -Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ; -print_endline "TIPO:" ; flush stdout ; -Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ; -print_endline "ENVIRONMENT:" ; flush stdout ; -Pp.ppnl (Printer.pr_context_of env) ; flush stdout ; -print_endline "FINE_ENVIRONMENT" ; flush stdout ; -*) - let innersort = - let synthesized_innersort = - get_sort_family_of env evar_map synthesized - in - match expected with - None -> synthesized_innersort - | Some ty -> - let expected_innersort = - get_sort_family_of env evar_map ty - in - match expected_innersort, synthesized_innersort with - CProp, _ - | _, CProp -> CProp - | _, _ -> expected_innersort - in -(* Debugging only: -print_endline "PASSATO" ; flush stdout ; -*) - let ainnertypes,expected_available = - if computeinnertypes then - let annexpected,expected_available = - match expected with - None -> None,false - | Some expectedty' -> - Some (aux false (Some fresh_id'') [] env idrefs expectedty'), - true - in - Some - {annsynthesized = - aux false (Some fresh_id'') [] env idrefs synthesized ; - annexpected = annexpected - }, expected_available - else - None,false - in - ainnertypes,synthesized, string_of_sort_family innersort, - expected_available - in - let add_inner_type id = - match ainnertypes with - None -> () - | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes - in - - (* explicit_substitute_and_eta_expand_if_required h t t' *) - (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit *) - (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = []) *) - (* check if [h] is a term that requires an explicit named *) - (* substitution and, in that case, uses the first arguments of *) - (* [t] as the actual arguments of the substitution. If there *) - (* are not enough parameters in the list [t], then eta-expansion *) - (* is performed. *) - let - explicit_substitute_and_eta_expand_if_required h t t' - compute_result_if_eta_expansion_not_required - = - let subst,residual_args,uninst_vars = - let variables,basedir = - try - let g = Libnames.global_of_constr h in - let sp = - match g with - Libnames.ConstructRef ((induri,_),_) - | Libnames.IndRef (induri,_) -> - Nametab.sp_of_global (Libnames.IndRef (induri,0)) - | Libnames.VarRef id -> - (* Invariant: variables are never cooked in Coq *) - raise Not_found - | _ -> Nametab.sp_of_global g - in - Dischargedhypsmap.get_discharged_hyps sp, - get_module_path_of_section_path sp - with Not_found -> - (* no explicit substitution *) - [], Libnames.dirpath_of_string "dummy" - in - (* returns a triple whose first element is *) - (* an explicit named substitution of "type" *) - (* (variable * argument) list, whose *) - (* second element is the list of residual *) - (* arguments and whose third argument is *) - (* the list of uninstantiated variables *) - let rec get_explicit_subst variables arguments = - match variables,arguments with - [],_ -> [],arguments,[] - | _,[] -> [],[],variables - | he1::tl1,he2::tl2 -> - let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in - let (he1_sp, he1_id) = Libnames.repr_path he1 in - let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in - let he1'' = - String.concat "/" - (List.map Names.string_of_id (List.rev he1')) ^ "/" - ^ (Names.string_of_id he1_id) ^ ".var" - in - (he1'',he2)::subst, extra_args, uninst - in - get_explicit_subst variables t' - in - let uninst_vars_length = List.length uninst_vars in - if uninst_vars_length > 0 then - (* Not enough arguments provided. We must eta-expand! *) - let un_args,_ = - T.decompose_prod_n uninst_vars_length - (CPropRetyping.get_type_of env evar_map tt) - in - let eta_expanded = - let arguments = - List.map (T.lift uninst_vars_length) t @ - Termops.rel_list 0 uninst_vars_length - in - Unshare.unshare - (T.lamn uninst_vars_length un_args - (T.applistc h arguments)) - in - D.double_type_of env evar_map eta_expanded - None terms_to_types ; - Hashtbl.remove ids_to_inner_types fresh_id'' ; - aux' env idrefs eta_expanded - else - compute_result_if_eta_expansion_not_required subst residual_args - in - - (* Now that we have all the auxiliary functions we *) - (* can finally proceed with the main case analysis. *) - match T.kind_of_term tt with - T.Rel n -> - let id = - match List.nth (E.rel_context env) (n - 1) with - (N.Name id,_,_) -> id - | (N.Anonymous,_,_) -> Nameops.make_ident "_" None - in - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort && expected_available then - add_inner_type fresh_id'' ; - A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) - | T.Var id -> - let pvars = Termops.ids_of_named_context (E.named_context env) in - let pvars = List.map N.string_of_id pvars in - let path = get_uri_of_var (N.string_of_id id) pvars in - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort && expected_available then - add_inner_type fresh_id'' ; - A.AVar - (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var") - | T.Evar (n,l) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort && expected_available then - add_inner_type fresh_id'' ; - A.AEvar - (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l)) - | T.Meta _ -> Util.anomaly "Meta met during exporting to XML" - | T.Sort s -> A.ASort (fresh_id'', s) - | T.Cast (v,_, t) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort then - add_inner_type fresh_id'' ; - A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t) - | T.Prod (n,s,t) -> - let n' = - match n with - N.Anonymous -> N.Anonymous - | _ -> - if not fake_dependent_products && T.noccurn 1 t then - N.Anonymous - else - N.Name - (Nameops.next_name_away n (Termops.ids_of_context env)) - in - Hashtbl.add ids_to_inner_sorts fresh_id'' - (string_of_sort innertype) ; - let sourcetype = CPropRetyping.get_type_of env evar_map s in - Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') - (string_of_sort sourcetype) ; - let new_passed_prods = - let father_is_prod = - match father with - None -> false - | Some father' -> - match - Term.kind_of_term (Hashtbl.find ids_to_terms father') - with - T.Prod _ -> true - | _ -> false - in - (fresh_id'', n', aux' env idrefs s):: - (if father_is_prod then - passed_lambdas_or_prods_or_letins - else []) - in - let new_env = E.push_rel (n', None, s) env in - let new_idrefs = fresh_id''::idrefs in - (match Term.kind_of_term t with - T.Prod _ -> - aux computeinnertypes (Some fresh_id'') new_passed_prods - new_env new_idrefs t - | _ -> - A.AProds (new_passed_prods, aux' new_env new_idrefs t)) - | T.Lambda (n,s,t) -> - let n' = - match n with - N.Anonymous -> N.Anonymous - | _ -> - N.Name (Nameops.next_name_away n (Termops.ids_of_context env)) - in - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - let sourcetype = CPropRetyping.get_type_of env evar_map s in - Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') - (string_of_sort sourcetype) ; - let father_is_lambda = - match father with - None -> false - | Some father' -> - match - Term.kind_of_term (Hashtbl.find ids_to_terms father') - with - T.Lambda _ -> true - | _ -> false - in - if is_a_Prop innersort && - ((not father_is_lambda) || expected_available) - then add_inner_type fresh_id'' ; - let new_passed_lambdas = - (fresh_id'',n', aux' env idrefs s):: - (if father_is_lambda then - passed_lambdas_or_prods_or_letins - else []) in - let new_env = E.push_rel (n', None, s) env in - let new_idrefs = fresh_id''::idrefs in - (match Term.kind_of_term t with - T.Lambda _ -> - aux computeinnertypes (Some fresh_id'') new_passed_lambdas - new_env new_idrefs t - | _ -> - let t' = aux' new_env new_idrefs t in - (* eta-expansion for explicit named substitutions *) - (* can create nested Lambdas. Here we perform the *) - (* flattening. *) - match t' with - A.ALambdas (lambdas, t'') -> - A.ALambdas (lambdas@new_passed_lambdas, t'') - | _ -> - A.ALambdas (new_passed_lambdas, t') - ) - | T.LetIn (n,s,t,d) -> - let id = - match n with - N.Anonymous -> N.id_of_string "_X" - | N.Name id -> id - in - let n' = - N.Name (Nameops.next_ident_away id (Termops.ids_of_context env)) - in - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - let sourcesort = - get_sort_family_of env evar_map - (CPropRetyping.get_type_of env evar_map s) - in - Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') - (string_of_sort_family sourcesort) ; - let father_is_letin = - match father with - None -> false - | Some father' -> - match - Term.kind_of_term (Hashtbl.find ids_to_terms father') - with - T.LetIn _ -> true - | _ -> false - in - if is_a_Prop innersort then - add_inner_type fresh_id'' ; - let new_passed_letins = - (fresh_id'',n', aux' env idrefs s):: - (if father_is_letin then - passed_lambdas_or_prods_or_letins - else []) in - let new_env = E.push_rel (n', Some s, t) env in - let new_idrefs = fresh_id''::idrefs in - (match Term.kind_of_term d with - T.LetIn _ -> - aux computeinnertypes (Some fresh_id'') new_passed_letins - new_env new_idrefs d - | _ -> A.ALetIns - (new_passed_letins, aux' new_env new_idrefs d)) - | T.App (h,t) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort then - add_inner_type fresh_id'' ; - let - compute_result_if_eta_expansion_not_required subst residual_args - = - let residual_args_not_empty = residual_args <> [] in - let h' = - if residual_args_not_empty then - aux' env idrefs ~subst:(None,subst) h - else - aux' env idrefs ~subst:(Some fresh_id'',subst) h - in - (* maybe all the arguments were used for the explicit *) - (* named substitution *) - if residual_args_not_empty then - A.AApp (fresh_id'', h'::residual_args) - else - h' - in - let t' = - Array.fold_right (fun x i -> (aux' env idrefs x)::i) t [] - in - explicit_substitute_and_eta_expand_if_required h - (Array.to_list t) t' - compute_result_if_eta_expansion_not_required - | T.Const kn -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort && expected_available then - add_inner_type fresh_id'' ; - let compute_result_if_eta_expansion_not_required _ _ = - A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn))) - in - let (_,subst') = subst in - explicit_substitute_and_eta_expand_if_required tt [] - (List.map snd subst') - compute_result_if_eta_expansion_not_required - | T.Ind (kn,i) -> - let compute_result_if_eta_expansion_not_required _ _ = - A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i) - in - let (_,subst') = subst in - explicit_substitute_and_eta_expand_if_required tt [] - (List.map snd subst') - compute_result_if_eta_expansion_not_required - | T.Construct ((kn,i),j) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort && expected_available then - add_inner_type fresh_id'' ; - let compute_result_if_eta_expansion_not_required _ _ = - A.AConstruct - (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j) - in - let (_,subst') = subst in - explicit_substitute_and_eta_expand_if_required tt [] - (List.map snd subst') - compute_result_if_eta_expansion_not_required - | T.Case ({T.ci_ind=(kn,i)},ty,term,a) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort then - add_inner_type fresh_id'' ; - let a' = - Array.fold_right (fun x i -> (aux' env idrefs x)::i) a [] - in - A.ACase - (fresh_id'', (uri_of_kernel_name (Inductive kn)), i, - aux' env idrefs ty, aux' env idrefs term, a') - | T.Fix ((ai,i),(f,t,b)) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort then add_inner_type fresh_id'' ; - let fresh_idrefs = - Array.init (Array.length t) (function _ -> gen_id seed) in - let new_idrefs = - (List.rev (Array.to_list fresh_idrefs)) @ idrefs - in - let f' = - let ids = ref (Termops.ids_of_context env) in - Array.map - (function - N.Anonymous -> Util.error "Anonymous fix function met" - | N.Name id as n -> - let res = N.Name (Nameops.next_name_away n !ids) in - ids := id::!ids ; - res - ) f - in - A.AFix (fresh_id'', i, - Array.fold_right - (fun (id,fi,ti,bi,ai) i -> - let fi' = - match fi with - N.Name fi -> fi - | N.Anonymous -> Util.error "Anonymous fix function met" - in - (id, fi', ai, - aux' env idrefs ti, - aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) - (Array.mapi - (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f' - ) [] - ) - | T.CoFix (i,(f,t,b)) -> - Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; - if is_a_Prop innersort then add_inner_type fresh_id'' ; - let fresh_idrefs = - Array.init (Array.length t) (function _ -> gen_id seed) in - let new_idrefs = - (List.rev (Array.to_list fresh_idrefs)) @ idrefs - in - let f' = - let ids = ref (Termops.ids_of_context env) in - Array.map - (function - N.Anonymous -> Util.error "Anonymous fix function met" - | N.Name id as n -> - let res = N.Name (Nameops.next_name_away n !ids) in - ids := id::!ids ; - res - ) f - in - A.ACoFix (fresh_id'', i, - Array.fold_right - (fun (id,fi,ti,bi) i -> - let fi' = - match fi with - N.Name fi -> fi - | N.Anonymous -> Util.error "Anonymous fix function met" - in - (id, fi', - aux' env idrefs ti, - aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) - (Array.mapi - (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f' - ) [] - ) - in - aux computeinnertypes None [] env idrefs t -;; - -(* Obsolete [HH 1/2009] -let acic_of_cic_context metasenv context t = - let ids_to_terms = Hashtbl.create 503 in - let constr_to_ids = Acic.CicHash.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let seed = ref 0 in - acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types metasenv context t, - ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types -;; -*) - -let acic_object_of_cic_object sigma obj = - let module A = Acic in - let ids_to_terms = Hashtbl.create 503 in - let constr_to_ids = Acic.CicHash.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - let ids_to_conjectures = Hashtbl.create 11 in - let ids_to_hypotheses = Hashtbl.create 127 in - let hypotheses_seed = ref 0 in - let conjectures_seed = ref 0 in - let seed = ref 0 in - let acic_term_of_cic_term_context' = - acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids - ids_to_inner_sorts ids_to_inner_types in -(*CSC: is this the right env to use? Hhmmm. There is a problem: in *) -(*CSC: Global.env () the object we are exporting is already defined, *) -(*CSC: either in the environment or in the named context (in the case *) -(*CSC: of variables. Is this a problem? *) - let env = Global.env () in - let acic_term_of_cic_term' ?fake_dependent_products = - acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in -(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *) -(*CSC: a modified version of the already existent fresh_id function *) - let fresh_id () = - let res = "i" ^ string_of_int !seed in - incr seed ; - res - in - let aobj = - match obj with - A.Constant (id,bo,ty,params) -> - let abo = - match bo with - None -> None - | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty)) - in - let aty = acic_term_of_cic_term' ty None in - A.AConstant (fresh_id (),id,abo,aty,params) - | A.Variable (id,bo,ty,params) -> - let abo = - match bo with - Some bo -> Some (acic_term_of_cic_term' bo (Some ty)) - | None -> None - in - let aty = acic_term_of_cic_term' ty None in - A.AVariable (fresh_id (),id,abo,aty,params) - | A.CurrentProof (id,conjectures,bo,ty) -> - let aconjectures = - List.map - (function (i,canonical_context,term) as conjecture -> - let cid = "c" ^ string_of_int !conjectures_seed in - Hashtbl.add ids_to_conjectures cid conjecture ; - incr conjectures_seed ; - let canonical_env,idrefs',acanonical_context = - let rec aux env idrefs = - function - [] -> env,idrefs,[] - | ((n,decl_or_def) as hyp)::tl -> - let hid = "h" ^ string_of_int !hypotheses_seed in - let new_idrefs = hid::idrefs in - Hashtbl.add ids_to_hypotheses hid hyp ; - incr hypotheses_seed ; - match decl_or_def with - A.Decl t -> - let final_env,final_idrefs,atl = - aux (Environ.push_rel (Names.Name n,None,t) env) - new_idrefs tl - in - let at = - acic_term_of_cic_term_context' env idrefs sigma t None - in - final_env,final_idrefs,(hid,(n,A.Decl at))::atl - | A.Def (t,ty) -> - let final_env,final_idrefs,atl = - aux - (Environ.push_rel (Names.Name n,Some t,ty) env) - new_idrefs tl - in - let at = - acic_term_of_cic_term_context' env idrefs sigma t None - in - let dummy_never_used = - let s = "dummy_never_used" in - A.ARel (s,99,s,Names.id_of_string s) - in - final_env,final_idrefs, - (hid,(n,A.Def (at,dummy_never_used)))::atl - in - aux env [] canonical_context - in - let aterm = - acic_term_of_cic_term_context' canonical_env idrefs' sigma term - None - in - (cid,i,List.rev acanonical_context,aterm) - ) conjectures in - let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in - let aty = acic_term_of_cic_term_context' env [] sigma ty None in - A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty) - | A.InductiveDefinition (tys,params,paramsno) -> - let env' = - List.fold_right - (fun (name,_,arity,_) env -> - Environ.push_rel (Names.Name name, None, arity) env - ) (List.rev tys) env in - let idrefs = List.map (function _ -> gen_id seed) tys in - let atys = - List.map2 - (fun id (name,inductive,ty,cons) -> - let acons = - List.map - (function (name,ty) -> - (name, - acic_term_of_cic_term_context' ~fake_dependent_products:true - env' idrefs Evd.empty ty None) - ) cons - in - let aty = - acic_term_of_cic_term' ~fake_dependent_products:true ty None - in - (id,name,inductive,aty,acons) - ) (List.rev idrefs) tys - in - A.AInductiveDefinition (fresh_id (),atys,params,paramsno) - in - aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts, - ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses -;; diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml deleted file mode 100644 index 17d1d5da..00000000 --- a/contrib/xml/doubleTypeInference.ml +++ /dev/null @@ -1,272 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *) -type types = {synthesized : Term.types ; expected : Term.types option};; - -let prerr_endline _ = ();; - -let cprop = - let module N = Names in - N.make_con - (N.MPfile - (Libnames.dirpath_of_string "CoRN.algebra.CLogic")) - (N.make_dirpath []) - (N.mk_label "CProp") -;; - -let whd_betadeltaiotacprop env _evar_map ty = - let module R = Rawterm in - let module C = Closure in - let module CR = C.RedFlags in - (*** CProp is made Opaque ***) - let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in - C.whd_val (C.create_clos_infos flags env) (C.inject ty) -;; - - -(* Code similar to the code in the Typing module, but: *) -(* - the term is already assumed to be well typed *) -(* - some checks have been removed *) -(* - both the synthesized and expected types of every *) -(* node are computed (Coscoy's double type inference) *) - -let assumption_of_judgment env sigma j = - Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j) -;; - -let type_judgment env sigma j = - Typeops.type_judgment env (Evarutil.j_nf_evar sigma j) -;; - -let type_judgment_cprop env sigma j = - match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with - | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s } - | _ -> None (* None means the CProp constant *) -;; - -let double_type_of env sigma cstr expectedty subterms_to_types = - (*CSC: the code is inefficient because judgments are created just to be *) - (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *) - (*CSC: functions used do checks that we do not need *) - let rec execute env sigma cstr expectedty = - let module T = Term in - let module E = Environ in - (* the type part is the synthesized type *) - let judgement = - match T.kind_of_term cstr with - T.Meta n -> - Util.error - "DoubleTypeInference.double_type_of: found a non-instanciated goal" - - | T.Evar ((n,l) as ev) -> - let ty = Unshare.unshare (Evd.existential_type sigma ev) in - let jty = execute env sigma ty None in - let jty = assumption_of_judgment env sigma jty in - let evar_context = - E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in - let rec iter actual_args evar_context = - match actual_args,evar_context with - [],[] -> () - | he1::tl1,(n,_,ty)::tl2 -> - (* for side-effects *) - let _ = execute env sigma he1 (Some ty) in - let tl2' = - List.map - (function (m,bo,ty) -> - (* Warning: the substitution should be performed also on bo *) - (* This is not done since bo is not used later yet *) - (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty)) - ) tl2 - in - iter tl1 tl2' - | _,_ -> assert false - in - (* for side effects only *) - iter (List.rev (Array.to_list l)) (List.rev evar_context) ; - E.make_judge cstr jty - - | T.Rel n -> - Typeops.judge_of_relative env n - - | T.Var id -> - Typeops.judge_of_variable env id - - | T.Const c -> - E.make_judge cstr (Typeops.type_of_constant env c) - - | T.Ind ind -> - E.make_judge cstr (Inductiveops.type_of_inductive env ind) - - | T.Construct cstruct -> - E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) - - | T.Case (ci,p,c,lf) -> - let expectedtype = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in - let cj = execute env sigma c (Some expectedtype) in - let pj = execute env sigma p None in - let (expectedtypes,_,_) = - let indspec = Inductive.find_rectype env cj.Environ.uj_type in - Inductive.type_case_branches env indspec pj cj.Environ.uj_val - in - let lfj = - execute_array env sigma lf - (Array.map (function x -> Some x) expectedtypes) in - let (j,_) = Typeops.judge_of_case env ci pj cj lfj in - j - - | T.Fix ((vn,i as vni),recdef) -> - let (_,tys,_ as recdef') = execute_recdef env sigma recdef in - let fix = (vni,recdef') in - E.make_judge (T.mkFix fix) tys.(i) - - | T.CoFix (i,recdef) -> - let (_,tys,_ as recdef') = execute_recdef env sigma recdef in - let cofix = (i,recdef') in - E.make_judge (T.mkCoFix cofix) tys.(i) - - | T.Sort (T.Prop c) -> - Typeops.judge_of_prop_contents c - - | T.Sort (T.Type u) -> -(*CSC: In case of need, I refresh the universe. But exportation of the *) -(*CSC: right universe level information is destroyed. It must be changed *) -(*CSC: again once Judicael will introduce his non-bugged algebraic *) -(*CSC: universes. *) -(try - Typeops.judge_of_type u - with _ -> (* Successor of a non universe-variable universe anomaly *) - (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; - Typeops.judge_of_type (Termops.new_univ ()) -) - - | T.App (f,args) -> - let expected_head = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in - let j = execute env sigma f (Some expected_head) in - let expected_args = - let rec aux typ = - function - [] -> [] - | hj::restjl -> - match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with - T.Prod (_,c1,c2) -> - (Some (Reductionops.nf_beta sigma c1)) :: - (aux (T.subst1 hj c2) restjl) - | _ -> assert false - in - Array.of_list (aux j.Environ.uj_type (Array.to_list args)) - in - let jl = execute_array env sigma args expected_args in - let (j,_) = Typeops.judge_of_apply env j jl in - j - - | T.Lambda (name,c1,c2) -> - let j = execute env sigma c1 None in - let var = type_judgment env sigma j in - let env1 = E.push_rel (name,None,var.E.utj_val) env in - let expectedc2type = - match expectedty with - None -> None - | Some ety -> - match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with - T.Prod (_,_,expected_target_type) -> - Some (Reductionops.nf_beta sigma expected_target_type) - | _ -> assert false - in - let j' = execute env1 sigma c2 expectedc2type in - Typeops.judge_of_abstraction env1 name var j' - - | T.Prod (name,c1,c2) -> - let j = execute env sigma c1 None in - let varj = type_judgment env sigma j in - let env1 = E.push_rel (name,None,varj.E.utj_val) env in - let j' = execute env1 sigma c2 None in - (match type_judgment_cprop env1 sigma j' with - Some varj' -> Typeops.judge_of_product env name varj varj' - | None -> - (* CProp found *) - { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val); - Environ.uj_type = T.mkConst cprop }) - - | T.LetIn (name,c1,c2,c3) -> -(*CSC: What are the right expected types for the source and *) -(*CSC: target of a LetIn? None used. *) - let j1 = execute env sigma c1 None in - let j2 = execute env sigma c2 None in - let j2 = type_judgment env sigma j2 in - let env1 = - E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env - in - let j3 = execute env1 sigma c3 None in - Typeops.judge_of_letin env name j1 j2 j3 - - | T.Cast (c,k,t) -> - let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in - let tj = execute env sigma t None in - let tj = type_judgment env sigma tj in - let j, _ = Typeops.judge_of_cast env cj k tj in - j - in - let synthesized = E.j_type judgement in - let synthesized' = Reductionops.nf_beta sigma synthesized in - let types,res = - match expectedty with - None -> - (* No expected type *) - {synthesized = synthesized' ; expected = None}, synthesized - | Some ty when Term.eq_constr synthesized' ty -> - (* The expected type is synthactically equal to the *) - (* synthesized type. Let's forget it. *) - (* Note: since eq_constr is up to casts, it is better *) - (* to keep the expected type, since it can bears casts *) - (* that change the innersort to CProp *) - {synthesized = ty ; expected = None}, ty - | Some expectedty' -> - {synthesized = synthesized' ; expected = Some expectedty'}, - expectedty' - in -(*CSC: debugging stuff to be removed *) -if Acic.CicHash.mem subterms_to_types cstr then - (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ; - Acic.CicHash.add subterms_to_types cstr types ; - E.make_judge cstr res - - - and execute_recdef env sigma (names,lar,vdef) = - let length = Array.length lar in - let larj = - execute_array env sigma lar (Array.make length None) in - let lara = Array.map (assumption_of_judgment env sigma) larj in - let env1 = Environ.push_rec_types (names,lara,vdef) env in - let expectedtypes = - Array.map (function i -> Some (Term.lift length i)) lar - in - let vdefj = execute_array env1 sigma vdef expectedtypes in - let vdefv = Array.map Environ.j_val vdefj in - (names,lara,vdefv) - - and execute_array env sigma v expectedtypes = - let jl = - execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes) - in - Array.of_list jl - - and execute_list env sigma = - List.map2 (execute env sigma) - -in - ignore (execute env sigma cstr expectedty) -;; diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli deleted file mode 100644 index 2e14b558..00000000 --- a/contrib/xml/doubleTypeInference.mli +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -type types = { synthesized : Term.types; expected : Term.types option; } - -val cprop : Names.constant - -val whd_betadeltaiotacprop : - Environ.env -> Evd.evar_map -> Term.constr -> Term.constr - -val double_type_of : - Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option -> - types Acic.CicHash.t -> unit diff --git a/contrib/xml/dumptree.ml4 b/contrib/xml/dumptree.ml4 deleted file mode 100644 index 407f86b3..00000000 --- a/contrib/xml/dumptree.ml4 +++ /dev/null @@ -1,152 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** This module provides the "Dump Tree" command that allows dumping the - current state of the proof stree in XML format *) - -(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *) - -(*i camlp4deps: "parsing/grammar.cma" i*) -open Tacexpr;; -open Decl_mode;; -open Printer;; -open Pp;; -open Environ;; -open Format;; -open Proof_type;; -open Evd;; -open Termops;; -open Ppconstr;; -open Names;; - -exception Different - -let xmlstream s = - (* In XML we want to print the whole stream so we can force the evaluation *) - Stream.of_list (List.map xmlescape (Stream.npeek max_int s)) -;; - -let thin_sign osign sign = - Sign.fold_named_context - (fun (id,c,ty as d) sign -> - try - if Sign.lookup_named id osign = (id,c,ty) then sign - else raise Different - with Not_found | Different -> Environ.push_named_context_val d sign) - sign ~init:Environ.empty_named_context_val -;; - -let pr_tactic_xml = function - | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" - | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>" -;; - -let pr_proof_instr_xml instr = - Ppdecl_proof.pr_proof_instr (Global.env()) instr -;; - -let pr_rule_xml pr = function - | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>" - | Nested(cmpd, subtree) -> - hov 2 (str "<cmpdrule>" ++ fnl () ++ - begin match cmpd with - Tactic (texp, _) -> pr_tactic_xml texp - | Proof_instr (_,instr) -> pr_proof_instr_xml instr - end ++ fnl () - ++ pr subtree - ) ++ fnl () ++ str "</cmpdrule>" - | Daimon -> str "<daimon/>" - | Decl_proof _ -> str "<proof/>" -(* | Change_evars -> str "<chgevars/>"*) -;; - -let pr_var_decl_xml env (id,c,typ) = - let ptyp = print_constr_env env typ in - match c with - | None -> - (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>") - | Some c -> - (* Force evaluation *) - let pb = print_constr_env env c in - (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++ - xmlstream pb ++ str "\"/>") -;; - -let pr_rel_decl_xml env (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> - (* Force evaluation *) - let pb = print_constr_env env c in - (str" body=\"" ++ xmlstream pb ++ str "\"") in - let ptyp = print_constr_env env typ in - let pid = - match na with - | Anonymous -> mt () - | Name id -> str " id=\"" ++ pr_id id ++ str "\"" - in - (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>") -;; - -let pr_context_xml env = - let sign_env = - fold_named_context - (fun env d pp -> pp ++ pr_var_decl_xml env d) - env ~init:(mt ()) - in - let db_env = - fold_rel_context - (fun env d pp -> pp ++ pr_rel_decl_xml env d) - env ~init:(mt ()) - in - (sign_env ++ db_env) -;; - -let pr_subgoal_metas_xml metas env= - let pr_one (meta, typ) = - fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ - str "\"/>" - in - List.fold_left (++) (mt ()) (List.map pr_one metas) -;; - -let pr_goal_xml g = - let env = try evar_env g with _ -> empty_env in - if g.evar_extra = None then - (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++ - xmlstream (pr_ltype_env_at_top env g.evar_concl) ++ - str "\"/>" ++ - (pr_context_xml env)) ++ - fnl () ++ str "</goal>") - else - (hov 2 (str "<goal type=\"declarative\">" ++ - (pr_context_xml env)) ++ - fnl () ++ str "</goal>") -;; - -let rec print_proof_xml sigma osign pf = - let hyps = Environ.named_context_of_val pf.goal.evar_hyps in - let hyps' = thin_sign osign hyps in - match pf.ref with - | None -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>" - | Some(r,spfl) -> - hov 2 (str "<tree>" ++ fnl () ++ - (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++ - (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>" -;; - -let print_proof_xml () = - let pp = print_proof_xml Evd.empty Sign.empty_named_context - (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) - in - msgnl pp -;; - -VERNAC COMMAND EXTEND DumpTree - [ "Dump" "Tree" ] -> [ print_proof_xml () ] -END diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml deleted file mode 100644 index 30dc7b71..00000000 --- a/contrib/xml/proof2aproof.ml +++ /dev/null @@ -1,176 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(* Note: we can not use the Set module here because we _need_ physical *) -(* equality and there exists no comparison function compatible with *) -(* physical equality. *) - -module S = - struct - let empty = [] - let mem = List.memq - let add x l = x::l - end -;; - -(* evar reduction that preserves some terms *) -let nf_evar sigma ~preserve = - let module T = Term in - let rec aux t = - if preserve t then t else - match T.kind_of_term t with - | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _ - | T.Construct _ -> t - | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2) - | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2) - | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c) - | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c) - | T.App (c,l) -> - let c' = aux c in - let l' = Array.map aux l in - (match T.kind_of_term c' with - T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') - | T.Cast (he,_,_) -> - (match T.kind_of_term he with - T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') - | _ -> T.mkApp (c', l') - ) - | _ -> T.mkApp (c', l')) - | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e -> - aux (Evd.existential_value sigma (e,l)) - | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l) - | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl) - | T.Fix (ln,(lna,tl,bl)) -> - T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl)) - | T.CoFix(ln,(lna,tl,bl)) -> - T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl)) - in - aux -;; - -(* Unshares a proof-tree. *) -(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) -let rec unshare_proof_tree = - let module PT = Proof_type in - function {PT.open_subgoals = status ; - PT.goal = goal ; - PT.ref = ref} -> - let unshared_ref = - match ref with - None -> None - | Some (rule,pfs) -> - let unshared_rule = - match rule with - PT.Nested (cmpd, pf) -> - PT.Nested (cmpd, unshare_proof_tree pf) - | other -> other - in - Some (unshared_rule, List.map unshare_proof_tree pfs) - in - {PT.open_subgoals = status ; - PT.goal = goal ; - PT.ref = unshared_ref} -;; - -module ProofTreeHash = - Hashtbl.Make - (struct - type t = Proof_type.proof_tree - let equal = (==) - let hash = Hashtbl.hash - end) -;; - - -let extract_open_proof sigma pf = - let module PT = Proof_type in - let module L = Logic in - let evd = ref (Evd.create_evar_defs sigma) in - let proof_tree_to_constr = ProofTreeHash.create 503 in - let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in - let unshared_constrs = ref S.empty in - let rec proof_extractor vl node = - let constr = - match node with - {PT.ref=Some(PT.Prim _,_)} as pf -> - L.prim_extractor proof_extractor vl pf - - | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> - let sgl,v = Refiner.frontier hidden_proof in - let flat_proof = v spfl in - ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; - proof_extractor vl flat_proof - - | {PT.ref=None;PT.goal=goal} -> - let visible_rels = - Util.map_succeed - (fun id -> - (* Section variables are in the [id] list but are not *) - (* lambda abstracted in the term [vl] *) - try let n = Logic.proof_variable_index id vl in (n,id) - with Not_found -> failwith "caught") -(*CSC: the above function must be modified such that when it is found *) -(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) -(*CSC: as the evar_instance. Ordering the instance becomes useless (it *) -(*CSC: will already be ordered. *) - (Termops.ids_of_named_context - (Environ.named_context_of_val goal.Evd.evar_hyps)) in - let sorted_rels = - Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in - let context = - let l = - List.map - (fun (_,id) -> Sign.lookup_named id - (Environ.named_context_of_val goal.Evd.evar_hyps)) - sorted_rels in - Environ.val_of_named_context l - in -(*CSC: the section variables in the right order must be added too *) - let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in - (* let env = Global.env_of_context context in *) - let evd',evar = - Evarutil.new_evar_instance context !evd goal.Evd.evar_concl - evar_instance in - evd := evd' ; - evar - - | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" - in - let unsharedconstr = - let evar_nf_constr = - nf_evar (Evd.evars_of !evd) - ~preserve:(function e -> S.mem e !unshared_constrs) constr - in - Unshare.unshare - ~already_unshared:(function e -> S.mem e !unshared_constrs) - evar_nf_constr - in -(*CSC: debugging stuff to be removed *) -if ProofTreeHash.mem proof_tree_to_constr node then - Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") - (Tactic_printer.print_proof (Evd.evars_of !evd) [] node)) ; - ProofTreeHash.add proof_tree_to_constr node unsharedconstr ; - unshared_constrs := S.add unsharedconstr !unshared_constrs ; - unsharedconstr - in - let unshared_pf = unshare_proof_tree pf in - let pfterm = proof_extractor [] unshared_pf in - (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, - unshared_pf) -;; - -let extract_open_pftreestate pts = - extract_open_proof (Refiner.evc_of_pftreestate pts) - (Tacmach.proof_of_pftreestate pts) -;; diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 deleted file mode 100644 index 7503d632..00000000 --- a/contrib/xml/proofTree2Xml.ml4 +++ /dev/null @@ -1,210 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";; - -let std_ppcmds_to_string s = - Pp.msg_with Format.str_formatter s; - Format.flush_str_formatter () -;; - -let idref_of_id id = "v" ^ id;; - -(* Transform a constr to an Xml.token Stream.t *) -(* env is a named context *) -(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *) -let constr_to_xml obj sigma env = - let ids_to_terms = Hashtbl.create 503 in - let constr_to_ids = Acic.CicHash.create 503 in - let ids_to_father_ids = Hashtbl.create 503 in - let ids_to_inner_sorts = Hashtbl.create 503 in - let ids_to_inner_types = Hashtbl.create 503 in - - (* named_context holds section variables and local variables *) - let named_context = Environ.named_context env in - (* real_named_context holds only the section variables *) - let real_named_context = Environ.named_context (Global.env ()) in - (* named_context' holds only the local variables *) - let named_context' = - List.filter (function n -> not (List.mem n real_named_context)) named_context - in - let idrefs = - List.map - (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in - let rel_context = Sign.push_named_to_rel_context named_context' [] in - let rel_env = - Environ.push_rel_context rel_context - (Environ.reset_with_named_context - (Environ.val_of_named_context real_named_context) env) in - let obj' = - Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in - let seed = ref 0 in - try - let annobj = - Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids - ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env - idrefs sigma (Unshare.unshare obj') None - in - Acic2Xml.print_term ids_to_inner_sorts annobj - with e -> - Util.anomaly - ("Problem during the conversion of constr into XML: " ^ - Printexc.to_string e) -(* CSC: debugging stuff -Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ; -Pp.ppnl (Pp.str "ENVIRONMENT:") ; -Pp.ppnl (Printer.pr_context_of rel_env) ; -Pp.ppnl (Pp.str "TERM:") ; -Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ; -Pp.ppnl (Pp.str "RAW-TERM:") ; -Pp.ppnl (Printer.pr_lconstr obj') ; -Xml.xml_empty "MISSING TERM" [] (*; raise e*) -*) -;; - -let first_word s = - try let i = String.index s ' ' in - String.sub s 0 i - with _ -> s -;; - -let string_of_prim_rule x = match x with - | Proof_type.Intro _-> "Intro" - | Proof_type.Cut _ -> "Cut" - | Proof_type.FixRule _ -> "FixRule" - | Proof_type.Cofix _ -> "Cofix" - | Proof_type.Refine _ -> "Refine" - | Proof_type.Convert_concl _ -> "Convert_concl" - | Proof_type.Convert_hyp _->"Convert_hyp" - | Proof_type.Thin _ -> "Thin" - | Proof_type.ThinBody _-> "ThinBody" - | Proof_type.Move (_,_,_) -> "Move" - | Proof_type.Order _ -> "Order" - | Proof_type.Rename (_,_) -> "Rename" - | Proof_type.Change_evars -> "Change_evars" - -let - print_proof_tree curi sigma pf proof_tree_to_constr - proof_tree_to_flattened_proof_tree constr_to_ids -= - let module PT = Proof_type in - let module L = Logic in - let module X = Xml in - let module T = Tacexpr in - let ids_of_node node = - let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in -(* -let constr = - try - Proof2aproof.ProofTreeHash.find proof_tree_to_constr node - with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated -no lambda-term: ") (Refiner.print_script true (Evd.empty) -(Global.named_context ()) node)) ; assert false (* Closed bug, should not -happen any more *) -in -*) - try - Some (Acic.CicHash.find constr_to_ids constr) - with _ -> -Pp.ppnl (Pp.(++) (Pp.str -"The_generated_term_is_not_a_subterm_of_the_final_lambda_term") -(Printer.pr_lconstr constr)) ; - None - in - let rec aux node old_hyps = - let of_attribute = - match ids_of_node node with - None -> [] - | Some id -> ["of",id] - in - match node with - {PT.ref=Some(PT.Prim tactic_expr,nodes)} -> - let tac = string_of_prim_rule tactic_expr in - let of_attribute = ("name",tac)::of_attribute in - if nodes = [] then - X.xml_empty "Prim" of_attribute - else - X.xml_nempty "Prim" of_attribute - (List.fold_left - (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) - - | {PT.goal=goal; - PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} -> - (* [hidden_proof] is the proof of the tactic; *) - (* [nodes] are the proof of the subgoals generated by the tactic; *) - (* [flat_proof] if the proof-tree obtained substituting [nodes] *) - (* for the holes in [hidden_proof] *) - let flat_proof = - Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node - in begin - match tactic_expr with - | T.TacArg (T.Tacexp _) -> - (* We don't need to keep the level of abstraction introduced at *) - (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) - aux flat_proof old_hyps - | _ -> - (****** la tactique employee *) - let prtac = Pptactic.pr_tactic (Global.env()) in - let tac = std_ppcmds_to_string (prtac tactic_expr) in - let tacname= first_word tac in - let of_attribute = ("name",tacname)::("script",tac)::of_attribute in - - (****** le but *) - let {Evd.evar_concl=concl; - Evd.evar_hyps=hyps}=goal in - - let env = Global.env_of_context hyps in - - let xgoal = - X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in - - let rec build_hyps = - function - | [] -> xgoal - | (id,c,tid)::hyps1 -> - let id' = Names.string_of_id id in - [< build_hyps hyps1; - (X.xml_nempty "Hypothesis" - ["id",idref_of_id id' ; "name",id'] - (constr_to_xml tid sigma env)) - >] in - let old_names = List.map (fun (id,c,tid)->id) old_hyps in - let nhyps = Environ.named_context_of_val hyps in - let new_hyps = - List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in - - X.xml_nempty "Tactic" of_attribute - [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] - end - - | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> - Util.anomaly "Not Implemented" - - | {PT.ref=Some(PT.Daimon,_)} -> - X.xml_empty "Hidden_open_goal" of_attribute - - | {PT.ref=None;PT.goal=goal} -> - X.xml_empty "Open_goal" of_attribute - in - [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; - X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n"); - X.xml_nempty "ProofTree" ["of",curi] (aux pf []) - >] -;; - - -(* Hook registration *) -(* CSC: debranched since it is bugged -Xmlcommand.set_print_proof_tree print_proof_tree;; -*) diff --git a/contrib/xml/theoryobject.dtd b/contrib/xml/theoryobject.dtd deleted file mode 100644 index 953fe009..00000000 --- a/contrib/xml/theoryobject.dtd +++ /dev/null @@ -1,62 +0,0 @@ -<?xml encoding="ISO-8859-1"?> - -<!-- Copyright (C) 2000-2004, HELM Team --> -<!-- --> -<!-- This file is part of HELM, an Hypertextual, Electronic --> -<!-- Library of Mathematics, developed at the Computer Science --> -<!-- Department, University of Bologna, Italy. --> -<!-- --> -<!-- HELM is free software; you can redistribute it and/or --> -<!-- modify it under the terms of the GNU General Public License --> -<!-- as published by the Free Software Foundation; either version 2 --> -<!-- of the License, or (at your option) any later version. --> -<!-- --> -<!-- HELM is distributed in the hope that it will be useful, --> -<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of --> -<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --> -<!-- GNU General Public License for more details. --> -<!-- --> -<!-- You should have received a copy of the GNU General Public License --> -<!-- along with HELM; if not, write to the Free Software --> -<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, --> -<!-- MA 02111-1307, USA. --> -<!-- --> -<!-- For details, see the HELM World-Wide-Web page, --> -<!-- http://cs.unibo.it/helm/. --> - - - -<!-- Notice: the markup described in this DTD is meant to be embedded --> -<!-- in foreign markup (e.g. XHTML) --> - -<!ENTITY % theorystructure - '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'> - -<!ELEMENT ht:SECTION (%theorystructure;)> -<!ATTLIST ht:SECTION - uri CDATA #REQUIRED> - -<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)> - -<!-- Theory Items --> - -<!ELEMENT ht:AXIOM (Axiom)> -<!ATTLIST ht:AXIOM - uri CDATA #REQUIRED - as (Axiom|Declaration) #REQUIRED> - -<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)> -<!ATTLIST ht:DEFINITION - uri CDATA #REQUIRED - as (Definition|InteractiveDefinition|Inductive|CoInductive - |Record) #REQUIRED> - -<!ELEMENT ht:THEOREM (type)> -<!ATTLIST ht:THEOREM - uri CDATA #REQUIRED - as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED> - -<!ELEMENT ht:VARIABLE (Variable)> -<!ATTLIST ht:VARIABLE - uri CDATA #REQUIRED - as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED> diff --git a/contrib/xml/unshare.ml b/contrib/xml/unshare.ml deleted file mode 100644 index f30f8230..00000000 --- a/contrib/xml/unshare.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -exception CanNotUnshare;; - -(* [unshare t] gives back a copy of t where all sharing has been removed *) -(* Physical equality becomes meaningful on unshared terms. Hashtables that *) -(* use physical equality can now be used to associate information to evey *) -(* node of the term. *) -let unshare ?(already_unshared = function _ -> false) t = - let obj = Obj.repr t in - let rec aux obj = - if already_unshared (Obj.obj obj) then - obj - else - (if Obj.is_int obj then - obj - else if Obj.is_block obj then - begin - let tag = Obj.tag obj in - if tag < Obj.no_scan_tag then - begin - let size = Obj.size obj in - let new_obj = Obj.new_block 0 size in - Obj.set_tag new_obj tag ; - for i = 0 to size - 1 do - Obj.set_field new_obj i (aux (Obj.field obj i)) - done ; - new_obj - end - else if tag = Obj.string_tag then - obj - else - raise CanNotUnshare - end - else - raise CanNotUnshare - ) - in - Obj.obj (aux obj) -;; diff --git a/contrib/xml/unshare.mli b/contrib/xml/unshare.mli deleted file mode 100644 index 31ba9037..00000000 --- a/contrib/xml/unshare.mli +++ /dev/null @@ -1,21 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -exception CanNotUnshare;; - -(* [unshare t] gives back a copy of t where all sharing has been removed *) -(* Physical equality becomes meaningful on unshared terms. Hashtables that *) -(* use physical equality can now be used to associate information to evey *) -(* node of the term. *) -val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4 deleted file mode 100644 index 5b217119..00000000 --- a/contrib/xml/xml.ml4 +++ /dev/null @@ -1,78 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(* the type token for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) -(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) -(* content *) -type token = Str of string - | Empty of string * (string * string) list - | NEmpty of string * (string * string) list * token Stream.t -;; - -(* currified versions of the constructors make the code more readable *) -let xml_empty name attrs = [< 'Empty(name,attrs) >] -let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] -let xml_cdata str = [< 'Str str >] - -(* Usage: *) -(* pp tokens None pretty prints the output on stdout *) -(* pp tokens (Some filename) pretty prints the output on the file filename *) -let pp_ch strm channel = - let rec pp_r m = - parser - [< 'Str a ; s >] -> - print_spaces m ; - fprint_string (a ^ "\n") ; - pp_r m s - | [< 'Empty(n,l) ; s >] -> - print_spaces m ; - fprint_string ("<" ^ n) ; - List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; - fprint_string "/>\n" ; - pp_r m s - | [< 'NEmpty(n,l,c) ; s >] -> - print_spaces m ; - fprint_string ("<" ^ n) ; - List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; - fprint_string ">\n" ; - pp_r (m+1) c ; - print_spaces m ; - fprint_string ("</" ^ n ^ ">\n") ; - pp_r m s - | [< >] -> () - and print_spaces m = - for i = 1 to m do fprint_string " " done - and fprint_string str = - output_string channel str - in - pp_r 0 strm -;; - - -let pp strm fn = - match fn with - Some filename -> - let filename = filename ^ ".xml" in - let ch = open_out filename in - pp_ch strm ch; - close_out ch ; - print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n"); - flush stdout - | None -> - pp_ch strm stdout -;; - diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli deleted file mode 100644 index 38a4e01c..00000000 --- a/contrib/xml/xml.mli +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(*i $Id: xml.mli 6681 2005-02-04 18:20:16Z herbelin $ i*) - -(* Tokens for XML cdata, empty elements and not-empty elements *) -(* Usage: *) -(* Str cdata *) -(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) -(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) -(* content *) -type token = - | Str of string - | Empty of string * (string * string) list - | NEmpty of string * (string * string) list * token Stream.t - -(* currified versions of the token constructors make the code more readable *) -val xml_empty : string -> (string * string) list -> token Stream.t -val xml_nempty : - string -> (string * string) list -> token Stream.t -> token Stream.t -val xml_cdata : string -> token Stream.t - -val pp_ch : token Stream.t -> out_channel -> unit - -(* The pretty printer for streams of token *) -(* Usage: *) -(* pp tokens None pretty prints the output on stdout *) -(* pp tokens (Some filename) pretty prints the output on the file filename *) -val pp : token Stream.t -> string option -> unit diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml deleted file mode 100644 index f4719594..00000000 --- a/contrib/xml/xmlcommand.ml +++ /dev/null @@ -1,708 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(* CONFIGURATION PARAMETERS *) - -let verbose = ref false;; - -(* HOOKS *) -let print_proof_tree, set_print_proof_tree = - let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in - (fun () -> !print_proof_tree), - (fun f -> - print_proof_tree := - fun - curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree - constr_to_ids - -> - Some - (f curi sigma0 pf proof_tree_to_constr - proof_tree_to_flattened_proof_tree constr_to_ids)) -;; - -(* UTILITY FUNCTIONS *) - -let print_if_verbose s = if !verbose then print_string s;; - -(* Next exception is used only inside print_coq_object and tag_of_string_tag *) -exception Uninteresting;; - -(* NOT USED anymore, we back to the V6 point of view with global parameters - -(* Internally, for Coq V7, params of inductive types are associated *) -(* not to the whole block of mutual inductive (as it was in V6) but to *) -(* each member of the block; but externally, all params are required *) -(* to be the same; the following function checks that the parameters *) -(* of each inductive of a same block are all the same, then returns *) -(* this number; it fails otherwise *) -let extract_nparams pack = - let module D = Declarations in - let module U = Util in - let module S = Sign in - - let {D.mind_nparams=nparams0} = pack.(0) in - let arity0 = pack.(0).D.mind_user_arity in - let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in - for i = 1 to Array.length pack - 1 do - let {D.mind_nparams=nparamsi} = pack.(i) in - let arityi = pack.(i).D.mind_user_arity in - let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in - if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block" - done; - nparams0 - -*) - -(* could_have_namesakes sp = true iff o is an object that could be cooked and *) -(* than that could exists in cooked form with the same name in a super *) -(* section of the actual section *) -let could_have_namesakes o sp = (* namesake = omonimo in italian *) - let module DK = Decl_kinds in - let module D = Declare in - let tag = Libobject.object_tag o in - print_if_verbose ("Object tag: " ^ tag ^ "\n") ; - match tag with - "CONSTANT" -> true (* constants/parameters are non global *) - | "INDUCTIVE" -> true (* mutual inductive types are never local *) - | "VARIABLE" -> false (* variables are local, so no namesakes *) - | _ -> false (* uninteresting thing that won't be printed*) -;; - -(* filter_params pvars hyps *) -(* filters out from pvars (which is a list of lists) all the variables *) -(* that does not belong to hyps (which is a simple list) *) -(* It returns a list of couples relative section path -- list of *) -(* variable names. *) -let filter_params pvars hyps = - let rec aux ids = - function - [] -> [] - | (id,he)::tl -> - let ids' = id::ids in - let ids'' = - "cic:/" ^ - String.concat "/" (List.rev (List.map Names.string_of_id ids')) in - let he' = - ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in - let tl' = aux ids' tl in - match he' with - _,[] -> tl' - | _,_ -> he'::tl' - in - let cwd = Lib.cwd () in - let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in - let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in - aux (Names.repr_dirpath modulepath) (List.rev pvars) -;; - -type variables_type = - Definition of string * Term.constr * Term.types - | Assumption of string * Term.constr -;; - -(* The computation is very inefficient, but we can't do anything *) -(* better unless this function is reimplemented in the Declare *) -(* module. *) -let search_variables () = - let module N = Names in - let cwd = Lib.cwd () in - let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in - let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in - let rec aux = - function - [] -> [] - | he::tl as modules -> - let one_section_variables = - let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in - let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in - [he,t] - in - one_section_variables @ aux tl - in - aux - (Cic2acic.remove_module_dirpath_from_dirpath - ~basedir:modulepath cwd) -;; - -(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *) - -let rec join_dirs cwd = - function - [] -> cwd - | he::tail -> - (try - Unix.mkdir cwd 0o775 - with _ -> () (* Let's ignore the errors on mkdir *) - ) ; - let newcwd = cwd ^ "/" ^ he in - join_dirs newcwd tail -;; - -let filename_of_path xml_library_root tag = - let module N = Names in - match xml_library_root with - None -> None (* stdout *) - | Some xml_library_root' -> - let tokens = Cic2acic.token_list_of_kernel_name tag in - Some (join_dirs xml_library_root' tokens) -;; - -let body_filename_of_filename = - function - Some f -> Some (f ^ ".body") - | None -> None -;; - -let types_filename_of_filename = - function - Some f -> Some (f ^ ".types") - | None -> None -;; - -let prooftree_filename_of_filename = - function - Some f -> Some (f ^ ".proof_tree") - | None -> None -;; - -let theory_filename xml_library_root = - let module N = Names in - match xml_library_root with - None -> None (* stdout *) - | Some xml_library_root' -> - let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in - (* theory from A/B/C/F.v goes into A/B/C/F.theory *) - let alltoks = List.rev toks in - Some (join_dirs xml_library_root' alltoks ^ ".theory") - -let print_object uri obj sigma proof_tree_infos filename = - (* function to pretty print and compress an XML file *) -(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *) - let pp xml filename = - Xml.pp xml filename ; - match filename with - None -> () - | Some fn -> - let fn' = - let rec escape s n = - try - let p = String.index_from s n '\'' in - String.sub s n (p - n) ^ "\\'" ^ escape s (p+1) - with Not_found -> String.sub s n (String.length s - n) - in - escape fn 0 - in - ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) - in - let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = - Cic2acic.acic_object_of_cic_object sigma obj in - let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in - let xmltypes = - Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in - pp xml filename ; - begin - match xml' with - None -> () - | Some xml' -> pp xml' (body_filename_of_filename filename) - end ; - pp xmltypes (types_filename_of_filename filename) ; - match proof_tree_infos with - None -> () - | Some (sigma0,proof_tree,proof_tree_to_constr, - proof_tree_to_flattened_proof_tree) -> - let xmlprooftree = - print_proof_tree () - uri sigma0 proof_tree proof_tree_to_constr - proof_tree_to_flattened_proof_tree constr_to_ids - in - match xmlprooftree with - None -> () - | Some xmlprooftree -> - pp xmlprooftree (prooftree_filename_of_filename filename) -;; - -let string_list_of_named_context_list = - List.map - (function (n,_,_) -> Names.string_of_id n) -;; - -(* Function to collect the variables that occur in a term. *) -(* Used only for variables (since for constants and mutual *) -(* inductive types this information is already available. *) -let find_hyps t = - let module T = Term in - let rec aux l t = - match T.kind_of_term t with - T.Var id when not (List.mem id l) -> - let (_,bo,ty) = Global.lookup_named id in - let boids = - match bo with - Some bo' -> aux l bo' - | None -> l - in - id::(aux boids ty) - | T.Var _ - | T.Rel _ - | T.Meta _ - | T.Evar _ - | T.Sort _ -> l - | T.Cast (te,_, ty) -> aux (aux l te) ty - | T.Prod (_,s,t) -> aux (aux l s) t - | T.Lambda (_,s,t) -> aux (aux l s) t - | T.LetIn (_,s,_,t) -> aux (aux l s) t - | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl - | T.Const con -> - let hyps = (Global.lookup_constant con).Declarations.const_hyps in - map_and_filter l hyps @ l - | T.Ind ind - | T.Construct (ind,_) -> - let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in - map_and_filter l hyps @ l - | T.Case (_,t1,t2,b) -> - Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b - | T.Fix (_,(_,tys,bodies)) - | T.CoFix (_,(_,tys,bodies)) -> - let r = Array.fold_left (fun i x -> aux i x) l tys in - Array.fold_left (fun i x -> aux i x) r bodies - and map_and_filter l = - function - [] -> [] - | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl) - | _::tl -> map_and_filter l tl - in - aux [] t -;; - -(* Functions to construct an object *) - -let mk_variable_obj id body typ = - let hyps,unsharedbody = - match body with - None -> [],None - | Some bo -> find_hyps bo, Some (Unshare.unshare bo) - in - let hyps' = find_hyps typ @ hyps in - let hyps'' = List.map Names.string_of_id hyps' in - let variables = search_variables () in - let params = filter_params variables hyps'' in - Acic.Variable - (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params) -;; - -(* Unsharing is not performed on the body, that must be already unshared. *) -(* The evar map and the type, instead, are unshared by this function. *) -let mk_current_proof_obj is_a_variable id bo ty evar_map env = - let unshared_ty = Unshare.unshare ty in - let metasenv = - List.map - (function - (n, {Evd.evar_concl = evar_concl ; - Evd.evar_hyps = evar_hyps} - ) -> - (* We map the named context to a rel context and every Var to a Rel *) - let final_var_ids,context = - let rec aux var_ids = - function - [] -> var_ids,[] - | (n,None,t)::tl -> - let final_var_ids,tl' = aux (n::var_ids) tl in - let t' = Term.subst_vars var_ids t in - final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl' - | (n,Some b,t)::tl -> - let final_var_ids,tl' = aux (n::var_ids) tl in - let b' = Term.subst_vars var_ids b in - (* t will not be exported to XML. Thus no unsharing performed *) - final_var_ids,(n, Acic.Def (Unshare.unshare b',t))::tl' - in - aux [] (List.rev (Environ.named_context_of_val evar_hyps)) - in - (* We map the named context to a rel context and every Var to a Rel *) - (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl)) - ) (Evarutil.non_instantiated evar_map) - in - let id' = Names.string_of_id id in - if metasenv = [] then - let ids = - Names.Idset.union - (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in - let hyps0 = Environ.keep_hyps env ids in - let hyps = string_list_of_named_context_list hyps0 in - (* Variables are the identifiers of the variables in scope *) - let variables = search_variables () in - let params = filter_params variables hyps in - if is_a_variable then - Acic.Variable (id',Some bo,unshared_ty,params) - else - Acic.Constant (id',Some bo,unshared_ty,params) - else - Acic.CurrentProof (id',metasenv,bo,unshared_ty) -;; - -let mk_constant_obj id bo ty variables hyps = - let hyps = string_list_of_named_context_list hyps in - let ty = Unshare.unshare ty in - let params = filter_params variables hyps in - match bo with - None -> - Acic.Constant (Names.string_of_id id,None,ty,params) - | Some c -> - Acic.Constant - (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)), - ty,params) -;; - -let mk_inductive_obj sp mib packs variables nparams hyps finite = - let module D = Declarations in - let hyps = string_list_of_named_context_list hyps in - let params = filter_params variables hyps in -(* let nparams = extract_nparams packs in *) - let tys = - let tyno = ref (Array.length packs) in - Array.fold_right - (fun p i -> - decr tyno ; - let {D.mind_consnames=consnames ; - D.mind_typename=typename } = p - in - let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in - let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in - let cons = - (Array.fold_right (fun (name,lc) i -> (name,lc)::i) - (Array.mapi - (fun j x ->(x,Unshare.unshare lc.(j))) consnames) - [] - ) - in - (typename,finite,Unshare.unshare arity,cons)::i - ) packs [] - in - Acic.InductiveDefinition (tys,params,nparams) -;; - -(* The current channel for .theory files *) -let theory_buffer = Buffer.create 4000;; - -let theory_output_string ?(do_not_quote = false) s = - (* prepare for coqdoc post-processing *) - let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in - print_if_verbose s; - Buffer.add_string theory_buffer s -;; - -let kind_of_global_goal = function - | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition" - | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k - | Decl_kinds.Local, _ -> assert false - -let kind_of_inductive isrecord kn = - "DEFINITION", - if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite - then if isrecord then "Record" else "Inductive" - else "CoInductive" -;; - -let kind_of_variable id = - let module DK = Decl_kinds in - match Decls.variable_kind id with - | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption" - | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis" - | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture" - | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition" - | DK.IsProof _ -> "VARIABLE","LocalFact" - | _ -> Util.anomaly "Unsupported variable kind" -;; - -let kind_of_constant kn = - let module DK = Decl_kinds in - match Decls.constant_kind kn with - | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" - | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" - | DK.IsAssumption DK.Conjectural -> - Pp.warning "Conjecture not supported in dtd (used Declaration instead)"; - "AXIOM","Declaration" - | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" - | DK.IsDefinition DK.Example -> - Pp.warning "Example not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Coercion -> - Pp.warning "Coercion not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.SubClass -> - Pp.warning "SubClass not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.CanonicalStructure -> - Pp.warning "CanonicalStructure not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Fixpoint -> - Pp.warning "Fixpoint not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.CoFixpoint -> - Pp.warning "CoFixpoint not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Scheme -> - Pp.warning "Scheme not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.StructureComponent -> - Pp.warning "StructureComponent not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.IdentityCoercion -> - Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Instance -> - Pp.warning "Instance not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsDefinition DK.Method -> - Pp.warning "Method not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" - | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> - "THEOREM",DK.string_of_theorem_kind thm - | DK.IsProof _ -> - Pp.warning "Unsupported theorem kind (used Theorem instead)"; - "THEOREM",DK.string_of_theorem_kind DK.Theorem -;; - -let kind_of_global r = - let module Ln = Libnames in - let module DK = Decl_kinds in - match r with - | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> - let isrecord = - try let _ = Recordops.lookup_projections kn in true - with Not_found -> false in - kind_of_inductive isrecord (fst kn) - | Ln.VarRef id -> kind_of_variable id - | Ln.ConstRef kn -> kind_of_constant kn -;; - -let print_object_kind uri (xmltag,variation) = - let s = - Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation - in - theory_output_string s -;; - -(* print id dest *) -(* where sp is the qualified identifier (section path) of a *) -(* definition/theorem, variable or inductive definition *) -(* and dest is either None (for stdout) or (Some filename) *) -(* pretty prints via Xml.pp the object whose identifier is id on dest *) -(* Note: it is printed only (and directly) the most cooked available *) -(* form of the definition (all the parameters are *) -(* lambda-abstracted, but the object can still refer to variables) *) -let print internal glob_ref kind xml_library_root = - let module D = Declarations in - let module De = Declare in - let module G = Global in - let module N = Names in - let module Nt = Nametab in - let module T = Term in - let module X = Xml in - let module Ln = Libnames in - (* Variables are the identifiers of the variables in scope *) - let variables = search_variables () in - let tag,obj = - match glob_ref with - Ln.VarRef id -> - (* this kn is fake since it is not provided by Coq *) - let kn = - let (mod_path,dir_path) = Lib.current_prefix () in - N.make_kn mod_path dir_path (N.label_of_id id) - in - let (_,body,typ) = G.lookup_named id in - Cic2acic.Variable kn,mk_variable_obj id body typ - | Ln.ConstRef kn -> - let id = N.id_of_label (N.con_label kn) in - let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} = - G.lookup_constant kn in - let typ = Typeops.type_of_constant_type (Global.env()) typ in - Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps - | Ln.IndRef (kn,_) -> - let mib = G.lookup_mind kn in - let {D.mind_nparams=nparams; - D.mind_packets=packs ; - D.mind_hyps=hyps; - D.mind_finite=finite} = mib in - Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite - | Ln.ConstructRef _ -> - Util.error ("a single constructor cannot be printed in XML") - in - let fn = filename_of_path xml_library_root tag in - let uri = Cic2acic.uri_of_kernel_name tag in - if not internal then print_object_kind uri kind; - print_object uri obj Evd.empty None fn -;; - -let print_ref qid fn = - let ref = Nametab.global qid in - print false ref (kind_of_global ref) fn - -(* show dest *) -(* where dest is either None (for stdout) or (Some filename) *) -(* pretty prints via Xml.pp the proof in progress on dest *) -let show_pftreestate internal fn (kind,pftst) id = - let pf = Tacmach.proof_of_pftreestate pftst in - let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in - let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, - unshared_pf - = - Proof2aproof.extract_open_pftreestate pftst in - let env = Global.env () in - let obj = - mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in - let uri = - match kind with - Decl_kinds.Local, _ -> - let uri = - "cic:/" ^ String.concat "/" - (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable) - in - let kind_of_var = "VARIABLE","LocalFact" in - if not internal then print_object_kind uri kind_of_var; - uri - | Decl_kinds.Global, _ -> - let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in - if not internal then print_object_kind uri (kind_of_global_goal kind); - uri - in - print_object uri obj evar_map - (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr, - proof_tree_to_flattened_proof_tree)) fn -;; - -let show fn = - let pftst = Pfedit.get_pftreestate () in - let (id,kind,_,_) = Pfedit.current_proof_statement () in - show_pftreestate false fn (kind,pftst) id -;; - - -(* Let's register the callbacks *) -let xml_library_root = - try - Some (Sys.getenv "COQ_XML_LIBRARY_ROOT") - with Not_found -> None -;; - -let proof_to_export = ref None (* holds the proof-tree to export *) -;; - -let _ = - Pfedit.set_xml_cook_proof - (function pftreestate -> proof_to_export := Some pftreestate) -;; - -let _ = - Declare.set_xml_declare_variable - (function (sp,kn) -> - let id = Libnames.basename sp in - print false (Libnames.VarRef id) (kind_of_variable id) xml_library_root ; - proof_to_export := None) -;; - -let _ = - Declare.set_xml_declare_constant - (function (internal,kn) -> - match !proof_to_export with - None -> - print internal (Libnames.ConstRef kn) (kind_of_constant kn) - xml_library_root - | Some pftreestate -> - (* It is a proof. Let's export it starting from the proof-tree *) - (* I saved in the Pfedit.set_xml_cook_proof callback. *) - let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in - show_pftreestate internal fn pftreestate - (Names.id_of_label (Names.con_label kn)) ; - proof_to_export := None) -;; - -let _ = - Declare.set_xml_declare_inductive - (function (isrecord,(sp,kn)) -> - print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) - xml_library_root) -;; - -let _ = - Vernac.set_xml_start_library - (function () -> - Buffer.reset theory_buffer; - theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n"; - theory_output_string ("<!DOCTYPE html [\n" ^ - "<!ENTITY % xhtml-lat1.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^ - "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^ - "<!ENTITY % xhtml-symbol.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^ - "%xhtml-lat1.ent;\n" ^ - "%xhtml-special.ent;\n" ^ - "%xhtml-symbol.ent;\n" ^ - "]>\n\n"); - theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n"; - theory_output_string "<head></head>\n<body>\n") -;; - -let _ = - Vernac.set_xml_end_library - (function () -> - theory_output_string "</body>\n</html>\n"; - let ofn = theory_filename xml_library_root in - begin - match ofn with - None -> - Buffer.output_buffer stdout theory_buffer ; - | Some fn -> - let ch = open_out (fn ^ ".v") in - Buffer.output_buffer ch theory_buffer ; - close_out ch; - (* dummy glob file *) - let ch = open_out (fn ^ ".glob") in - close_out ch - end ; - Option.iter - (fun fn -> - let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in - let options = " --html -s --body-only --no-index --latin1 --raw-comments" in - let command cmd = - if Sys.command cmd <> 0 then - Util.anomaly ("Error executing \"" ^ cmd ^ "\"") - in - command (coqdoc^options^" -o "^fn^".xml "^fn^".v"); - command ("rm "^fn^".v "^fn^".glob"); - print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n")) - ofn) -;; - -let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; - -let uri_of_dirpath dir = - "/" ^ String.concat "/" - (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) -;; - -let _ = - Lib.set_xml_open_section - (fun _ -> - let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in - theory_output_string ("<ht:SECTION uri=\""^s^"\">")) -;; - -let _ = - Lib.set_xml_close_section - (fun _ -> theory_output_string "</ht:SECTION>") -;; - -let _ = - Library.set_xml_require - (fun d -> theory_output_string - (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>" - (uri_of_dirpath d) (Names.string_of_dirpath d))) -;; diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli deleted file mode 100644 index 7c0d31a1..00000000 --- a/contrib/xml/xmlcommand.mli +++ /dev/null @@ -1,41 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(*i $Id: xmlcommand.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) - -(* print_global qid fn *) -(* where qid is a long name denoting a definition/theorem or *) -(* an inductive definition *) -(* and dest is either None (for stdout) or (Some filename) *) -(* pretty prints via Xml.pp the object whose name is ref on dest *) -(* Note: it is printed only (and directly) the most discharged available *) -(* form of the definition (all the parameters are *) -(* lambda-abstracted, but the object can still refer to variables) *) -val print_ref : Libnames.reference -> string option -> unit - -(* show dest *) -(* where dest is either None (for stdout) or (Some filename) *) -(* pretty prints via Xml.pp the proof in progress on dest *) -val show : string option -> unit - -(* set_print_proof_tree f *) -(* sets a callback function f to export the proof_tree to XML *) -val set_print_proof_tree : - (string -> - Evd.evar_map -> - Proof_type.proof_tree -> - Term.constr Proof2aproof.ProofTreeHash.t -> - Proof_type.proof_tree Proof2aproof.ProofTreeHash.t -> - string Acic.CicHash.t -> Xml.token Stream.t) -> - unit diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4 deleted file mode 100644 index 496debe1..00000000 --- a/contrib/xml/xmlentries.ml4 +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) -(* \VV/ **************************************************************) -(* // * The HELM Project / The EU MoWGLI Project *) -(* * University of Bologna *) -(************************************************************************) -(* This file is distributed under the terms of the *) -(* GNU Lesser General Public License Version 2.1 *) -(* *) -(* Copyright (C) 2000-2004, HELM Team. *) -(* http://helm.cs.unibo.it *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: xmlentries.ml4 5920 2004-07-16 20:01:26Z herbelin $ *) - -open Util;; -open Vernacinterp;; - -open Extend;; -open Genarg;; -open Pp;; -open Pcoq;; - -(* File name *) - -VERNAC ARGUMENT EXTEND filename -| [ "File" string(fn) ] -> [ Some fn ] -| [ ] -> [ None ] -END - -(* Print XML and Show XML *) - -VERNAC COMMAND EXTEND Xml -| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ] - -| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ] -END |