diff options
Diffstat (limited to 'contrib')
268 files changed, 32066 insertions, 6046 deletions
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml index e73a6221..8bdae54b 100644 --- a/contrib/cc/ccalgo.ml +++ b/contrib/cc/ccalgo.ml @@ -6,45 +6,33 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.ml,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *) +(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *) (* This file implements the basic congruence-closure algorithm by *) (* Downey,Sethi and Tarjan. *) open Util +open Pp +open Goptions open Names open Term -let init_size=251 - -type pa_constructor= - {head_constr: int; - arity:int; - nhyps:int; - args:int list; - term_head:int} +let init_size=5 +let cc_verbose=ref false -module PacMap=Map.Make(struct type t=int*int let compare=compare end) +let debug msg (stdpp:std_ppcmds) = + if !cc_verbose then msg stdpp -type term= - Symb of constr - | Appli of term*term - | Constructor of constructor*int*int (* constructor arity+ nhyps *) - -type rule= - Congruence - | Axiom of identifier - | Injection of int*int*int*int (* terms+head+arg position *) - -type equality = {lhs:int;rhs:int;rule:rule} - -let swap eq= - let swap_rule=match eq.rule with - Congruence -> Congruence - | Injection (i,j,c,a) -> Injection (j,i,c,a) - | Axiom id -> anomaly "no symmetry for axioms" - in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} +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 *) @@ -67,291 +55,723 @@ module ST=struct 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 t st= + 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_list l st= - match l with - []->() - | t::q -> delete t st;delete_list q st + let rec delete_set st s = Intset.iter (delete st) s end - -(* Basic Union-Find algo w/o path compression *) - -module UF = struct -module IndMap=Map.Make(struct type t=inductive let compare=compare end) +type pa_constructor= + { cnode : int; + arity : int; + args : int list} - type representative= - {mutable nfathers:int; - mutable fathers:int list; - mutable constructors:pa_constructor PacMap.t; - mutable inductives:(int * int) IndMap.t} +type pa_fun= + {fsym:int; + fnargs:int} - type cl = Rep of representative| Eqto of int*equality +type pa_mark= + Fmark of pa_fun + | Cmark of pa_constructor - type vertex = Leaf| Node of (int*int) +module PacMap=Map.Make(struct + type t=pa_constructor + let compare=Pervasives.compare end) - type node = - {clas:cl; - vertex:vertex; - term:term; - mutable node_constr: int PacMap.t} +module PafMap=Map.Make(struct + type t=pa_fun + let compare=Pervasives.compare end) - type t={mutable size:int; - map:(int,node) Hashtbl.t; - syms:(term,int) Hashtbl.t; - sigtable:ST.t} +type cinfo= + {ci_constr: constructor; (* inductive type *) + ci_arity: int; (* # args *) + ci_nhyps: int} (* # projectable args *) - let empty ():t={size=0; - map=Hashtbl.create init_size; - syms=Hashtbl.create init_size; - sigtable=ST.empty ()} +type term= + Symb of constr + | Eps + | Appli of term*term + | Constructor of cinfo (* constructor arity + nhyps *) - let rec find uf i= - match (Hashtbl.find uf.map i).clas with - Rep _ -> i - | Eqto (j,_) ->find uf j - - let get_representative uf i= - let node=Hashtbl.find uf.map i in - match node.clas with - Rep r ->r - | _ -> anomaly "get_representative: not a representative" +type ccpattern = + PApp of term * ccpattern list (* arguments are reversed *) + | PVar of int - let get_constructor uf i= - match (Hashtbl.find uf.map i).term with - Constructor (cstr,_,_)->cstr - | _ -> anomaly "get_constructor: not a constructor" +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 - let fathers uf i= - (get_representative uf i).fathers - - let size uf i= - (get_representative uf i).nfathers +type 'a eq = {lhs:int;rhs:int;rule:'a} - let add_father uf i t= - let r=get_representative uf i in - r.nfathers<-r.nfathers+1; - r.fathers<-t::r.fathers +type equality = rule eq - let pac_map uf i= - (get_representative uf i).constructors +type disequality = from eq - let pac_arity uf i sg= - (PacMap.find sg (get_representative uf i).constructors).arity +type quant_eq = + {qe_hyp_id: identifier; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:bool; + qe_rhs: ccpattern; + qe_rhs_valid:bool} - let add_node_pac uf i sg j= - let node=Hashtbl.find uf.map i in - if not (PacMap.mem sg node.node_constr) then - node.node_constr<-PacMap.add sg j node.node_constr - - let mem_node_pac uf i sg= - PacMap.find sg (Hashtbl.find uf.map i).node_constr +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 nfathers:int; + mutable lfathers:Intset.t; + mutable fathers:Intset.t; + mutable inductive_status: inductive_status; + 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 - exception Discriminable of int * int * int * int * t - - let add_pacs uf i pacs = - let rep=get_representative uf i in - let pending=ref [] and combine=ref [] in - let add_pac sg pac= - try - let opac=PacMap.find sg rep.constructors in - if (snd sg)>0 then () else - let tk=pac.term_head - and tl=opac.term_head in - let rec f n lk ll q= - if n > 0 then match (lk,ll) with - k::qk,l::ql-> - let eq= - {lhs=k;rhs=l;rule=Injection(tk,tl,pac.head_constr,n)} - in f (n-1) qk ql (eq::q) - | _-> anomaly - "add_pacs : weird error in injection subterms merge" - else q in - combine:=f pac.nhyps pac.args opac.args !combine - with Not_found -> (* Still Unknown Constructor *) - rep.constructors <- PacMap.add sg pac rep.constructors; - pending:= - (fathers uf (find uf pac.term_head)) @rep.fathers@ !pending; - let (c,a)=sg in - if a=0 then - let (ind,_)=get_constructor uf c in - try - let th2,hc2=IndMap.find ind rep.inductives in - raise (Discriminable (pac.term_head,c,th2,hc2,uf)) - with Not_found -> - rep.inductives<- - IndMap.add ind (pac.term_head,c) rep.inductives in - PacMap.iter add_pac pacs; - !pending,!combine +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: (constr,unit) Hashtbl.t; + mutable rew_depth:int; + mutable changed:bool} + +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: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; + changed=false} + +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 term uf i=(Hashtbl.find uf.map i).term - - let subterms uf i= - match (Hashtbl.find 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 nodes uf= (* cherche les noeuds binaires *) - Hashtbl.fold - (fun i node l-> - match node.vertex with - Node (_,_)->i::l - | _ ->l) uf.map [] - - let next uf= - let n=uf.size in uf.size<-n+1; n +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 new_representative pm im= - {nfathers=0; - fathers=[]; - constructors=pm; - inductives=im} +let size uf i= + (get_representative uf i).nfathers + +let axioms uf = uf.axioms + +let epsilons uf = uf.epsilons + +let add_lfather uf i t= + let r=get_representative uf i in + r.nfathers<-r.nfathers+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.nfathers<-r.nfathers+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 rec add uf t= +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 ()= + {nfathers=0; + lfathers=Intset.empty; + fathers=Intset.empty; + inductive_status=Unknown; + functions=PafMap.empty; + constructors=PacMap.empty} + +(* rebuild a constr from an applicative term *) + +let rec constr_of_term = function + Symb s->s + | Eps -> anomaly "epsilon constant has no value" + | 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 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 new_node= match t with - Symb s -> - {clas=Rep (new_representative PacMap.empty IndMap.empty); - vertex=Leaf;term=t;node_constr=PacMap.empty} + Symb _ -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + {clas= Rep (new_representative ()); + cpath= -1; + vertex= Leaf; + term= t} + | Eps -> + {clas= Rep (new_representative ()); + cpath= -1; + vertex= Leaf; + term= t} | Appli (t1,t2) -> - let i1=add uf t1 and i2=add uf t2 in - add_father uf (find uf i1) b; - add_father uf (find uf i2) b; - {clas=Rep (new_representative PacMap.empty IndMap.empty); - vertex=Node(i1,i2);term=t;node_constr=PacMap.empty} - | Constructor (c,a,n) -> - let pacs= - PacMap.add (b,a) - {head_constr=b;arity=a;nhyps=n;args=[];term_head=b} - PacMap.empty in - let inds= - if a=0 then - let (ind,_)=c in - IndMap.add ind (b,b) IndMap.empty - else IndMap.empty in - {clas=Rep (new_representative pacs inds); - vertex=Leaf;term=t;node_constr=PacMap.empty} + 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 ()); + 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 ()); + cpath= -1; + vertex=Leaf; + term=t} in - Hashtbl.add uf.map b new_node; + uf.map.(b)<-new_node; Hashtbl.add uf.syms t b; b - let link uf i j eq= (* links i -> j *) - let node=Hashtbl.find uf.map i in - Hashtbl.replace uf.map i {node with clas=Eqto (j,eq)} - - let union uf i1 i2 eq= - let r1= get_representative uf i1 - and r2= get_representative uf i2 in - link uf i1 i2 eq; - r2.nfathers<-r1.nfathers+r2.nfathers; - r2.fathers<-r1.fathers@r2.fathers; - add_pacs uf i2 r1.constructors +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 add_inst state (inst,int_subst) = + if state.rew_depth > 0 then + 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 + try Hashtbl.find state.q_history prf + with Not_found -> + (* this instance is new, we can go on *) + 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 msgnl + (str "adding new equality, depth="++ int state.rew_depth); + add_equality state prf s t + end + else + begin + debug msgnl (str "adding new disequality, depth="++ + int state.rew_depth); + add_disequality state (Hyp prf) s t + 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 (Hashtbl.find 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 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 join_path uf i j= - assert (find uf i=find uf j); - min_path (down_path uf i [],down_path uf j []) +let rec min_path=function + ([],l2)->([],l2) + | (l1,[])->(l1,[]) + | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) + | cpl -> cpl -end - -let rec combine_rec uf=function - []->[] - | t::pending-> - let combine=combine_rec uf pending in - let s=UF.signature uf t in - let u=snd (UF.subterms uf t) in - let f (c,a) pac pacs= - if a=0 then pacs else - let sg=(c,a-1) in - UF.add_node_pac uf t sg pac.term_head; - PacMap.add sg {pac with args=u::pac.args;term_head=t} pacs - in - let pacs=PacMap.fold f (UF.pac_map uf (fst s)) PacMap.empty in - let i=UF.find uf t in - let (p,c)=UF.add_pacs uf i pacs in - let combine2=(combine_rec uf p)@c@combine in - try {lhs=t;rhs=ST.query s uf.UF.sigtable;rule=Congruence}::combine2 with - Not_found-> - ST.enter t s uf.UF.sigtable;combine2 - -let rec process_rec uf=function - []->[] - | eq::combine-> - let pending=process_rec uf combine in - let i=UF.find uf eq.lhs - and j=UF.find uf eq.rhs in - if i=j then - pending +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 msgnl (str "Linking " ++ int i1 ++ str " and " ++ int i2 ++ str "."); + let r1= get_representative state.uf i1 + and r2= get_representative state.uf i2 in + link state.uf i1 i2 eq; + let f= Intset.union r1.fathers r2.fathers in + r2.nfathers<-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 msgnl + (str "Merging " ++ int eq.lhs ++ str " and " ++ int 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 - if (UF.size uf i)<(UF.size uf j) then - let l=UF.fathers uf i in - let (p,c)=UF.union uf i j eq in - let _ =ST.delete_list l uf.UF.sigtable in - let inj_pending=process_rec uf c in - inj_pending@p@l@pending + union state j i (swap eq) + +let update t state = (* update 1 and 2 *) + debug msgnl + (str "Updating term " ++ int 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 msgnl + (str "Processing mark for term " ++ int 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 msg + (str "Checking if " ++ int dis.lhs ++ str " = " ++ + int dis.rhs ++ str " ... "); + if find uf dis.lhs=find uf dis.rhs then + begin debug msgnl (str "Yes");Some dis end else - let l=UF.fathers uf j in - let (p,c)=UF.union uf j i (swap eq) in - let _ =ST.delete_list l uf.UF.sigtable in - let inj_pending=process_rec uf c in - inj_pending@p@l@pending + 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 rec cc_rec uf=function - []->() - | pending-> - let combine=combine_rec uf pending in - let pending0=process_rec uf combine in - cc_rec uf pending0 - -let cc uf=cc_rec uf (UF.nodes uf) - -let rec make_uf=function - []->UF.empty () - | (ax,(t1,t2))::q-> - let uf=make_uf q in - let i1=UF.add uf t1 in - let i2=UF.add uf t2 in - let j1=UF.find uf i1 and j2=UF.find uf i2 in - if j1=j2 then uf else - let (_,inj_combine)= - UF.union uf j1 j2 {lhs=i1;rhs=i2;rule=Axiom ax} in - let _ = process_rec uf inj_combine in uf - -let add_one_diseq uf (t1,t2)=(UF.add uf t1,UF.add uf t2) -let add_disaxioms uf disaxioms= - let f (id,cpl)=(id,add_one_diseq uf cpl) in - List.map f disaxioms +let complete_one_class state i= + match (get_representative state.uf i).inductive_status with + Partial pac -> + let rec app t n = + if n<=0 then t else + app (Appli(t,Eps)) (n-1) in + state.uf.epsilons <- pac :: state.uf.epsilons; + ignore (add_term state (app (term state.uf i) pac.arity)) + | _ -> 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 + for cl=0 to pred uf.size do + match uf.map.(cl).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 cl elem) !funtab) + rep.functions + | _ -> () + done; + !funtab + -let check_equal uf (i1,i2) = UF.find uf i1 = UF.find uf i2 +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 + | 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) = ST.rev_query i state.sigtable 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 + if inst.qe_lhs_valid then + try + let paf= paf_of_patt syms inst.qe_lhs in + let good_classes = PafMap.find paf funtab 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 + with Not_found -> () + end; + begin + if inst.qe_rhs_valid then + try + let paf= paf_of_patt syms inst.qe_rhs in + let good_classes = PafMap.find paf funtab 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 + with Not_found -> () + 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 + 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 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 -let find_contradiction uf diseq = - List.find (fun (id,cpl) -> check_equal uf cpl) diseq - diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli index 47cdb3ea..05a5c4d1 100644 --- a/contrib/cc/ccalgo.mli +++ b/contrib/cc/ccalgo.mli @@ -6,15 +6,148 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.mli,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *) +(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *) -type pa_constructor - (*{head: int; arity: int; args: (int * int) list}*) +open Util +open Term +open Names -module PacMap:Map.S with type key=int * int +type cinfo = + {ci_constr: constructor; (* inductive type *) + ci_arity: int; (* # args *) + ci_nhyps: int} (* # projectable args *) + +type term = + Symb of constr + | Eps + | Appli of term*term + | Constructor of cinfo (* constructor arity + nhyps *) + +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 -> 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 * bool * ccpattern * bool * 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:bool; + qe_rhs: ccpattern; + qe_rhs_valid:bool} + + +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 @@ -79,6 +212,6 @@ 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 index fa525e65..1ffa347a 100644 --- a/contrib/cc/ccproof.ml +++ b/contrib/cc/ccproof.ml @@ -6,18 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.ml,v 1.8.2.1 2004/07/16 19:29:58 herbelin Exp $ *) +(* $Id: ccproof.ml 9151 2006-09-19 13:32:22Z 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 proof= - Ax of identifier - | SymAx of identifier + Ax of constr + | SymAx of constr | Refl of term | Trans of proof*proof | Congr of proof*proof @@ -51,8 +52,8 @@ let pcongr=function let build_proof uf= let rec equal_proof i j= - if i=j then Refl (UF.term uf i) else - let (li,lj)=UF.join_path uf i j in + if i=j then Refl (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)= @@ -60,45 +61,44 @@ let build_proof uf= let pj=psym (equal_proof j eq.rhs) in let pij= match eq.rule with - Axiom s->Ax s + Axiom (s,reversed)->if reversed then SymAx s else Ax s | Congruence ->congr_proof eq.lhs eq.rhs - | Injection (ti,tj,c,a) -> - let p=equal_proof ti tj in - let p1=constr_proof ti ti c 0 - and p2=constr_proof tj tj c 0 in - match UF.term uf c with - Constructor (cstr,nargs,nhyps) -> - Inject(ptrans(psym p1,ptrans(p,p2)),cstr,nhyps,a) - | _ -> anomaly "injection on non-constructor terms" + | Injection (ti,ipac,tj,jpac,k) -> + let p=ind_proof ti ipac tj jpac in + let cinfo= get_constructor_info uf ipac.cnode in + Inject(p,cinfo.ci_constr,cinfo.ci_nhyps,k) in ptrans(ptrans (pi,pij),pj) - and constr_proof i j c n= - try - let nj=UF.mem_node_pac uf j (c,n) in - let (ni,arg)=UF.subterms uf j in - let p=constr_proof ni nj c (n+1) in - let targ=UF.term uf arg in - ptrans (equal_proof i j, pcongr (p,Refl targ)) - with Not_found->equal_proof i j + 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,Refl targ)) and path_proof i=function - [] -> Refl (UF.term uf i) + [] -> Refl (term uf i) | x::q->ptrans (path_proof (snd (fst x)) q,edge_proof x) and congr_proof i j= - let (i1,i2) = UF.subterms uf i - and (j1,j2) = UF.subterms uf j in + let (i1,i2) = subterms uf i + and (j1,j2) = subterms uf j in pcongr (equal_proof i1 j1, equal_proof i2 j2) - and discr_proof i ci j cj= + and ind_proof i ipac j jpac= let p=equal_proof i j - and p1=constr_proof i i ci 0 - and p2=constr_proof j j cj 0 in + and p1=constr_proof i i ipac + and p2=constr_proof j j jpac in ptrans(psym p1,ptrans(p,p2)) in function - `Prove_goal (i,j) | `Refute_hyp (i,j) -> equal_proof i j - | `Discriminate (i,ci,j,cj)-> discr_proof i ci j cj + `Prove (i,j) -> equal_proof i j + | `Discr (i,ci,j,cj)-> ind_proof i ci j cj let rec nth_arg t n= match t with @@ -110,8 +110,8 @@ let rec nth_arg t n= let rec type_proof axioms p= match p with - Ax s->List.assoc s axioms - | SymAx s-> let (t1,t2)=List.assoc s axioms in (t2,t1) + Ax s->Hashtbl.find axioms s + | SymAx s-> let (t1,t2)=Hashtbl.find axioms s in (t2,t1) | Refl t-> t,t | Trans (p1,p2)-> let (s1,t1)=type_proof axioms p1 @@ -125,33 +125,3 @@ let rec type_proof axioms p= let (ti,tj)=type_proof axioms p in nth_arg ti (n-a),nth_arg tj (n-a) -let by_contradiction uf diseq axioms disaxioms= - try - let id,cpl=find_contradiction uf diseq in - let prf=build_proof uf (`Refute_hyp cpl) in - if List.assoc id disaxioms=type_proof axioms prf then - `Refute_hyp (id,prf) - else - anomaly "wrong proof generated" - with Not_found -> - errorlabstrm "Congruence" (Pp.str "I couldn't solve goal") - -let cc_proof axioms disaxioms glo= - try - let uf=make_uf axioms in - let diseq=add_disaxioms uf disaxioms in - match glo with - Some cpl -> - let goal=add_one_diseq uf cpl in cc uf; - if check_equal uf goal then - let prf=build_proof uf (`Prove_goal goal) in - if cpl=type_proof axioms prf then - `Prove_goal prf - else anomaly "wrong proof generated" - else by_contradiction uf diseq axioms disaxioms - | None -> cc uf; by_contradiction uf diseq axioms disaxioms - with UF.Discriminable (i,ci,j,cj,uf) -> - let prf=build_proof uf (`Discriminate (i,ci,j,cj)) in - `Discriminate (UF.get_constructor uf ci,prf) - - diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli index 887ed070..abdd6fea 100644 --- a/contrib/cc/ccproof.mli +++ b/contrib/cc/ccproof.mli @@ -6,40 +6,26 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.mli,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *) +(* $Id: ccproof.mli 9151 2006-09-19 13:32:22Z corbinea $ *) open Ccalgo open Names +open Term type proof = - Ax of identifier - | SymAx of identifier + Ax of constr + | SymAx of constr | Refl of term | Trans of proof * proof | Congr of proof * proof | Inject of proof * constructor * int * int -val pcongr : proof * proof -> proof -val ptrans : proof * proof -> proof -val psym : proof -> proof -val pcongr : proof * proof -> proof - val build_proof : - UF.t -> - [ `Discriminate of int * int * int * int - | `Prove_goal of int * int - | `Refute_hyp of int * int ] - -> proof + forest -> + [ `Discr of int * pa_constructor * int * pa_constructor + | `Prove of int * int ] -> proof val type_proof : - (identifier * (term * term)) list -> proof -> term * term - -val cc_proof : - (identifier * (term * term)) list -> - (identifier * (term * term)) list -> - (term * term) option -> - [ `Discriminate of constructor * proof - | `Prove_goal of proof - | `Refute_hyp of identifier * proof ] + (constr, (term * term)) Hashtbl.t -> proof -> term * term diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml new file mode 100644 index 00000000..ea8aceeb --- /dev/null +++ b/contrib/cc/cctac.ml @@ -0,0 +1,382 @@ +(************************************************************************) +(* 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 9151 2006-09-19 13:32:22Z corbinea $ *) + +(* 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 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 _eq = constant ["Init";"Logic"] "eq" + +let _False = constant ["Init";"Logic"] "False" + +(* decompose member of equality in an applicative format *) + +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)) + +let rec decompose_term env t= + match kind_of_term (whd env t) with + App (f,args)-> + let tf=decompose_term env f in + let targs=Array.map (decompose_term env) args in + Array.fold_left (fun s t->Appli (s,t)) tf targs + | 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 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 args.(1), + decompose_term env args.(2)) + else `Other (decompose_term env term) + | _ -> `Other (decompose_term env term) + +let rec pattern_of_constr env c = + match kind_of_term (whd env c) with + App (f,args)-> + let pf = decompose_term env f in + let pargs,lrels = List.split + (array_map_to_list (pattern_of_constr env) args) in + PApp (pf,List.rev pargs), + List.fold_left Intset.union Intset.empty lrels + | Rel i -> PVar i,Intset.singleton i + | _ -> + let pf = decompose_term env c in + PApp (pf,[]),Intset.empty + +let non_trivial = function + PVar _ -> false + | _ -> true + +let patterns_of_constr env 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 args.(1) + and patt2,rels2 = pattern_of_constr env args.(2) in + let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) + and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in + if valid1 || valid2 then + nrels,valid1,patt1,valid2,patt2 + else raise Not_found + else raise Not_found + +let rec quantified_atom_of_constr env 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 nrels atom in + `Nrule patts + else + quantified_atom_of_constr env (succ nrels) ff + | _ -> + let patts=patterns_of_constr env nrels term in + `Rule patts + +let litteral_of_constr env 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 atom) with + `Eq(t,a,b) -> `Neq(t,a,b) + | `Other(p) -> `Nother(p) + else + begin + try + quantified_atom_of_constr env 1 ff + with Not_found -> + `Other (decompose_term env term) + end + | _ -> + atom_of_constr env term + + +(* store all equalities from the context *) + +let rec make_prb gls depth additionnal_terms = + let env=pf_env gls in + let state = empty depth in + let pos_hyps = ref [] in + let neg_hyps =ref [] in + List.iter + (fun c -> + let t = decompose_term env 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 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 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=(snd cstr)-1 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_default_case_info (pf_env gls) RegularStyle ind 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 rec proof_tac axioms=function + Ax c -> exact_check c + | SymAx c -> tclTHEN symmetry (exact_check c) + | Refl t -> reflexivity + | Trans (p1,p2)->let t=(constr_of_term (snd (type_proof axioms p1))) in + (tclTHENS (transitivity t) + [(proof_tac axioms p1);(proof_tac axioms p2)]) + | Congr (p1,p2)-> + fun gls-> + let (f1,f2)=(type_proof axioms p1) + and (x1,x2)=(type_proof axioms p2) in + let tf1=constr_of_term f1 and tx1=constr_of_term x1 + and tf2=constr_of_term f2 and tx2=constr_of_term x2 in + let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1 + and typfx=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|]) + and lemma2= + mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2|]) in + (tclTHENS (transitivity (mkApp(tf2,[|tx1|]))) + [tclTHEN (apply lemma1) (proof_tac axioms p1); + tclFIRST + [tclTHEN (apply lemma2) (proof_tac axioms p2); + reflexivity; + fun gls -> + errorlabstrm "Congruence" + (Pp.str + "I don't know how to handle dependent equality")]] + gls) + | Inject (prf,cstr,nargs,argind) as gprf-> + (fun gls -> + let ti,tj=type_proof axioms prf in + let ai,aj=type_proof axioms gprf in + let cti=constr_of_term ti in + let ctj=constr_of_term tj in + let cai=constr_of_term ai in + let intype=pf_type_of gls cti in + let outtype=pf_type_of gls cai in + let special=mkRel (1+nargs-argind) in + let default=constr_of_term ai in + let proj=build_projection intype outtype cstr special default gls in + let injt= + mkApp (Lazy.force _f_equal,[|intype;outtype;proj;cti;ctj|]) in + tclTHEN (apply injt) (proof_tac axioms prf) gls) + +let refute_tac axioms c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in + let intype=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 (true_cut (Name hid) neweq) + [proof_tac axioms p; simplest_elim false_t] gls + +let convert_to_goal_tac axioms c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in + let sort=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 (true_cut (Name e) neweq) + [proof_tac axioms p;exact_check endt] gls + +let convert_to_hyp_tac axioms 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 (true_cut (Name h) tt2) + [convert_to_goal_tac axioms c1 t1 t2 p; + simplest_elim false_t] gls + +let discriminate_tac axioms cstr p gls = + let t1,t2=type_proof axioms p in + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in + let intype=pf_type_of gls tt1 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;tt1;tt2;mkVar hid|]) in + let endt=mkApp (Lazy.force _eq_rect, + [|outtype;trivial;pred;identity;concl;injt|]) in + let neweq=mkApp(Lazy.force _eq,[|intype;tt1;tt2|]) in + tclTHENS (true_cut (Name hid) neweq) + [proof_tac axioms 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 (axioms uf) cstr p gls + | Incomplete -> + let metacnt = ref 0 in + let newmeta _ = incr metacnt; mkMeta !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 + let axioms = axioms uf in + match dis.rule with + Goal -> proof_tac axioms p gls + | Hyp id -> refute_tac axioms id ta tb p gls + | HeqG id -> + convert_to_goal_tac axioms id ta tb p gls + | HeqnH (ida,idb) -> + convert_to_hyp_tac axioms 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 diff --git a/contrib/cc/cctac.ml4 b/contrib/cc/cctac.ml4 deleted file mode 100644 index 49fe46fe..00000000 --- a/contrib/cc/cctac.ml4 +++ /dev/null @@ -1,247 +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.ml4,v 1.13.2.1 2004/07/16 19:29:59 herbelin Exp $ *) - -(* 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 Ccalgo -open Tacinterp -open Ccproof -open Pp -open Util -open Format - -exception Not_an_eq - -let fail()=raise Not_an_eq - -let constant dir s = lazy (Coqlib.gen_constant "CC" dir s) - -let f_equal_theo = constant ["Init";"Logic"] "f_equal" - -let eq_rect_theo = constant ["Init";"Logic"] "eq_rect" - -(* decompose member of equality in an applicative format *) - -let rec decompose_term env t= - match kind_of_term t with - App (f,args)-> - let tf=decompose_term env f in - let targs=Array.map (decompose_term env) args in - Array.fold_left (fun s t->Appli (s,t)) tf targs - | Construct c-> - let (_,oib)=Global.lookup_inductive (fst c) in - let nargs=mis_constructor_nargs_env env c in - Constructor (c,nargs,nargs-oib.mind_nparams) - | _ ->(Symb t) - -(* decompose equality in members and type *) - -let rec eq_type_of_term term= - match kind_of_term term with - App (f,args)-> - (try - let ref = reference_of_constr f in - if ref=Coqlib.glob_eq && (Array.length args)=3 - then (true,args.(0),args.(1),args.(2)) - else - if ref=(Lazy.force Coqlib.coq_not_ref) && - (Array.length args)=1 then - let (pol,t,a,b)=eq_type_of_term args.(0) in - if pol then (false,t,a,b) else fail () - else fail () - with Not_found -> fail ()) - | Prod (_,eq,ff) -> - (try - let ref = reference_of_constr ff in - if ref=(Lazy.force Coqlib.coq_False_ref) then - let (pol,t,a,b)=eq_type_of_term eq in - if pol then (false,t,a,b) else fail () - else fail () - with Not_found -> fail ()) - | _ -> fail () - -(* read an equality *) - -let read_eq env term= - let (pol,_,t1,t2)=eq_type_of_term term in - (pol,(decompose_term env t1,decompose_term env t2)) - -(* rebuild a term from applicative format *) - -let rec make_term=function - Symb s->s - | Constructor(c,_,_)->mkConstruct c - | Appli (s1,s2)-> - make_app [(make_term s2)] s1 -and make_app l=function - Symb s->applistc s l - | Constructor(c,_,_)->applistc (mkConstruct c) l - | Appli (s1,s2)->make_app ((make_term s2)::l) s1 - -(* store all equalities from the context *) - -let rec read_hyps env=function - []->[],[] - | (id,_,e)::hyps->let eq,diseq=read_hyps env hyps in - try let pol,cpl=read_eq env e in - if pol then - ((id,cpl)::eq),diseq - else - eq,((id,cpl)::diseq) - with Not_an_eq -> eq,diseq - -(* build a problem ( i.e. read the goal as an equality ) *) - -let make_prb gl= - let env=pf_env gl in - let eq,diseq=read_hyps env gl.it.evar_hyps in - try - let pol,cpl=read_eq env gl.it.evar_concl in - if pol then (eq,diseq,Some cpl) else assert false with - Not_an_eq -> (eq,diseq,None) - -(* 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 destApplication intype with - Invalid_argument _ -> (intype,[||]) in - let ind=destInd h in - let types=Inductive.arities_of_constructors env ind in - let lp=Array.length types in - let ci=(snd cstr)-1 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_default_case_info (pf_env gls) RegularStyle ind 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 rec proof_tac axioms=function - Ax id->exact_check (mkVar id) - | SymAx id->tclTHEN symmetry (exact_check (mkVar id)) - | Refl t->reflexivity - | Trans (p1,p2)->let t=(make_term (snd (type_proof axioms p1))) in - (tclTHENS (transitivity t) - [(proof_tac axioms p1);(proof_tac axioms p2)]) - | Congr (p1,p2)-> - fun gls-> - let (f1,f2)=(type_proof axioms p1) - and (x1,x2)=(type_proof axioms p2) in - let tf1=make_term f1 and tx1=make_term x1 - and tf2=make_term f2 and tx2=make_term x2 in - let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1 - and typfx=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_theo,[|typf;typfx;appx1;tf1;tf2|]) - and lemma2= - mkApp(Lazy.force f_equal_theo,[|typx;typfx;tf2;tx1;tx2|]) in - (tclTHENS (transitivity (mkApp(tf2,[|tx1|]))) - [tclTHEN (apply lemma1) (proof_tac axioms p1); - tclFIRST - [tclTHEN (apply lemma2) (proof_tac axioms p2); - reflexivity; - fun gls -> - errorlabstrm "Congruence" - (Pp.str - "I don't know how to handle dependent equality")]] - gls) - | Inject (prf,cstr,nargs,argind) as gprf-> - (fun gls -> - let ti,tj=type_proof axioms prf in - let ai,aj=type_proof axioms gprf in - let cti=make_term ti in - let ctj=make_term tj in - let cai=make_term ai in - let intype=pf_type_of gls cti in - let outtype=pf_type_of gls cai in - let special=mkRel (1+nargs-argind) in - let default=make_term ai in - let proj=build_projection intype outtype cstr special default gls in - let injt= - mkApp (Lazy.force f_equal_theo,[|intype;outtype;proj;cti;ctj|]) in - tclTHEN (apply injt) (proof_tac axioms prf) gls) - -let refute_tac axioms disaxioms id p gls = - let t1,t2=List.assoc id disaxioms in - let tt1=make_term t1 and tt2=make_term t2 in - let intype=pf_type_of gls tt1 in - let neweq= - mkApp(constr_of_reference Coqlib.glob_eq, - [|intype;tt1;tt2|]) in - let hid=pf_get_new_id (id_of_string "Heq") gls in - let false_t=mkApp (mkVar id,[|mkVar hid|]) in - tclTHENS (true_cut (Name hid) neweq) - [proof_tac axioms p; simplest_elim false_t] gls - -let discriminate_tac axioms cstr p gls = - let t1,t2=type_proof axioms p in - let tt1=make_term t1 and tt2=make_term t2 in - let intype=pf_type_of gls tt1 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_theo, - [|intype;outtype;proj;tt1;tt2;mkVar hid|]) in - let endt=mkApp (Lazy.force eq_rect_theo, - [|outtype;trivial;pred;identity;concl;injt|]) in - let neweq=mkApp(constr_of_reference Coqlib.glob_eq,[|intype;tt1;tt2|]) in - tclTHENS (true_cut (Name hid) neweq) - [proof_tac axioms p;exact_check endt] gls - -(* wrap everything *) - -let cc_tactic gls= - Library.check_required_library ["Coq";"Init";"Logic"]; - let (axioms,disaxioms,glo)=make_prb gls in - match (cc_proof axioms disaxioms glo) with - `Prove_goal p -> proof_tac axioms p gls - | `Refute_hyp (id,p) -> refute_tac axioms disaxioms id p gls - | `Discriminate (cstr,p) -> discriminate_tac axioms cstr p gls - -(* Tactic registration *) - -TACTIC EXTEND CC - [ "Congruence" ] -> [ tclSOLVE [tclTHEN (tclREPEAT introf) cc_tactic] ] -END - diff --git a/contrib/cc/CCSolve.v b/contrib/cc/cctac.mli index fab6f775..97fa4d77 100644 --- a/contrib/cc/CCSolve.v +++ b/contrib/cc/cctac.mli @@ -6,17 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: CCSolve.v,v 1.4.2.1 2004/07/16 19:29:58 herbelin Exp $ *) +(* $Id: cctac.mli 9151 2006-09-19 13:32:22Z corbinea $ *) -Ltac CCsolve := - repeat - match goal with - | H:?X1 |- ?X2 => - let Heq := fresh "Heq" in - (assert (Heq : X2 = X1); [ congruence | rewrite Heq; exact H ]) - | H:?X1,G:(?X2 -> ?X3) |- _ => - let Heq := fresh "Heq" in - (assert (Heq : X2 = X1); - [ congruence - | rewrite Heq in G; generalize (G H); clear G; intro G ]) - end. +open Term +open Proof_type + +val cc_tactic : int -> constr list -> tactic + +val cc_fail : tactic + +val congruence_tac : int -> constr list -> tactic diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4 new file mode 100644 index 00000000..693aebb4 --- /dev/null +++ b/contrib/cc/g_congruence.ml4 @@ -0,0 +1,25 @@ +(************************************************************************) +(* 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 9151 2006-09-19 13:32:22Z corbinea $ *) + +open Cctac +open Tactics +open Tacticals + +(* Tactic registration *) + +TACTIC EXTEND cc + [ "congruence" ] -> [ congruence_tac 0 [] ] + |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ] + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + [ congruence_tac n l ] +END diff --git a/contrib/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v index b352045a..30f5ac8f 100644 --- a/contrib/correctness/ArrayPermut.v +++ b/contrib/correctness/ArrayPermut.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ArrayPermut.v,v 1.3.2.1 2004/07/16 19:29:59 herbelin Exp $ *) +(* $Id: ArrayPermut.v 5920 2004-07-16 20:01:26Z herbelin $ *) (****************************************************************************) (* Permutations of elements in arrays *) diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v index 1659917a..3a6aaaf8 100644 --- a/contrib/correctness/Arrays.v +++ b/contrib/correctness/Arrays.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Arrays.v,v 1.9.2.1 2004/07/16 19:29:59 herbelin Exp $ *) +(* $Id: Arrays.v 5920 2004-07-16 20:01:26Z herbelin $ *) (**********************************************) (* Functional arrays, for use in Correctness. *) diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v index 899d7007..a8a2858f 100644 --- a/contrib/correctness/Arrays_stuff.v +++ b/contrib/correctness/Arrays_stuff.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Arrays_stuff.v,v 1.2.16.1 2004/07/16 19:29:59 herbelin Exp $ *) +(* $Id: Arrays_stuff.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Exchange. Require Export ArrayPermut. diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v index a2ad2f50..b7513d09 100644 --- a/contrib/correctness/Correctness.v +++ b/contrib/correctness/Correctness.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Correctness.v,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *) +(* $Id: Correctness.v 5920 2004-07-16 20:01:26Z herbelin $ *) (* Correctness is base on the tactic Refine (developped on purpose) *) diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v index 7dc5218e..035a98f2 100644 --- a/contrib/correctness/Exchange.v +++ b/contrib/correctness/Exchange.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Exchange.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: Exchange.v 5920 2004-07-16 20:01:26Z herbelin $ *) (****************************************************************************) (* Exchange of two elements in an array *) diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v index bce19870..38448efc 100644 --- a/contrib/correctness/ProgBool.v +++ b/contrib/correctness/ProgBool.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ProgBool.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: ProgBool.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Import ZArith. Require Export Bool_nat. diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v index c26e3553..b1eaaea7 100644 --- a/contrib/correctness/ProgInt.v +++ b/contrib/correctness/ProgInt.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ProgInt.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: ProgInt.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export ZArith. Require Export ZArith_dec. diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v index 40253f33..5f7dfdbf 100644 --- a/contrib/correctness/ProgramsExtraction.v +++ b/contrib/correctness/ProgramsExtraction.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ProgramsExtraction.v,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: ProgramsExtraction.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Extraction. diff --git a/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v index 1ca4b63e..6489de81 100644 --- a/contrib/correctness/Programs_stuff.v +++ b/contrib/correctness/Programs_stuff.v @@ -8,6 +8,6 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Programs_stuff.v,v 1.1.16.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $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 index 2efe54a4..ca4ed880 100644 --- a/contrib/correctness/Sorted.v +++ b/contrib/correctness/Sorted.v @@ -8,7 +8,7 @@ (* Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *) -(* $Id: Sorted.v,v 1.7.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: Sorted.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Arrays. Require Import ArrayPermut. diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v index e3fff08d..c7071f32 100644 --- a/contrib/correctness/Tuples.v +++ b/contrib/correctness/Tuples.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Tuples.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: Tuples.v 5920 2004-07-16 20:01:26Z herbelin $ *) (* Tuples *) diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v index 8c983a72..abb1cc76 100644 --- a/contrib/correctness/examples/Handbook.v +++ b/contrib/correctness/examples/Handbook.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: Handbook.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) +(* $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, diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v index dcfcec87..3142e906 100644 --- a/contrib/correctness/examples/exp.v +++ b/contrib/correctness/examples/exp.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(*i $Id: exp.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ i*) +(*i $Id: exp.v 1577 2001-04-11 07:56:19Z filliatr $ i*) (* Efficient computation of X^n using * diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v index accd60c2..044263ca 100644 --- a/contrib/correctness/examples/exp_int.v +++ b/contrib/correctness/examples/exp_int.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: exp_int.v,v 1.4 2001/04/11 07:56:19 filliatr Exp $ *) +(* $Id: exp_int.v 1577 2001-04-11 07:56:19Z filliatr $ *) (* Efficient computation of X^n using * diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v index e480c806..07e77140 100644 --- a/contrib/correctness/examples/fact.v +++ b/contrib/correctness/examples/fact.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: fact.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) +(* $Id: fact.v 1577 2001-04-11 07:56:19Z filliatr $ *) (* Proof of an imperative program computing the factorial (over type nat) *) diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v index cb2b0460..f463ca80 100644 --- a/contrib/correctness/examples/fact_int.v +++ b/contrib/correctness/examples/fact_int.v @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: fact_int.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) +(* $Id: fact_int.v 1577 2001-04-11 07:56:19Z filliatr $ *) (* Proof of an imperative program computing the factorial (over type Z) *) diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli index 1cc7164e..70328704 100644 --- a/contrib/correctness/past.mli +++ b/contrib/correctness/past.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: past.mli,v 1.7.6.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: past.mli 5920 2004-07-16 20:01:26Z herbelin $ *) (*s Abstract syntax of imperative programs. *) diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml index e87ba70c..041cd81f 100644 --- a/contrib/correctness/pcic.ml +++ b/contrib/correctness/pcic.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pcic.ml,v 1.23.2.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: pcic.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Util open Names diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli index 89731472..67b152f3 100644 --- a/contrib/correctness/pcic.mli +++ b/contrib/correctness/pcic.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(*i $Id: pcic.mli,v 1.3.16.1 2004/07/16 19:30:00 herbelin Exp $ i*) +(*i $Id: pcic.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) open Past open Rawterm diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml index cc15c8f3..368d0281 100644 --- a/contrib/correctness/pcicenv.ml +++ b/contrib/correctness/pcicenv.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pcicenv.ml,v 1.5.14.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: pcicenv.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli index fc4fa0b9..365fa960 100644 --- a/contrib/correctness/pcicenv.mli +++ b/contrib/correctness/pcicenv.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pcicenv.mli,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *) +(* $Id: pcicenv.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Penv open Names diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml index 302db871..759e9133 100644 --- a/contrib/correctness/pdb.ml +++ b/contrib/correctness/pdb.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pdb.ml,v 1.8.2.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pdb.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli index a0df29bd..d6e647b7 100644 --- a/contrib/correctness/pdb.mli +++ b/contrib/correctness/pdb.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pdb.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pdb.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Ptype open Past diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml index 08d6b002..faf5f3d3 100644 --- a/contrib/correctness/peffect.ml +++ b/contrib/correctness/peffect.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: peffect.ml,v 1.3.14.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: peffect.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Nameops diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli index d6d0ce22..9a10dea4 100644 --- a/contrib/correctness/peffect.mli +++ b/contrib/correctness/peffect.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: peffect.mli,v 1.1.16.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: peffect.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml index 820d1cf0..7f89b1e1 100644 --- a/contrib/correctness/penv.ml +++ b/contrib/correctness/penv.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: penv.ml,v 1.10.2.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: penv.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Pmisc open Past diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli index ef2e4c6e..6743b465 100644 --- a/contrib/correctness/penv.mli +++ b/contrib/correctness/penv.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: penv.mli,v 1.3.8.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: penv.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Ptype open Past diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml index 40fe4c98..8415e96d 100644 --- a/contrib/correctness/perror.ml +++ b/contrib/correctness/perror.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: perror.ml,v 1.9.2.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: perror.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Util diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli index 40b2d25c..45b2acdc 100644 --- a/contrib/correctness/perror.mli +++ b/contrib/correctness/perror.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: perror.mli,v 1.2.6.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: perror.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Util diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml index 2a35d471..407567ad 100644 --- a/contrib/correctness/pextract.ml +++ b/contrib/correctness/pextract.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pextract.ml,v 1.5.6.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pextract.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp_control open Pp diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli index dc5b4124..3492729c 100644 --- a/contrib/correctness/pextract.mli +++ b/contrib/correctness/pextract.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pextract.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pextract.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index aed8c5cb..076b11cd 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmisc.ml,v 1.18.2.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Pp open Util @@ -216,7 +216,7 @@ let rec type_v_knsubst s = function and type_c_knsubst s ((id,v),e,pl,q) = ((id, type_v_knsubst s v), e, List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl, - option_app (fun q -> { q with a_value = subst_mps s q.a_value }) q) + option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q) and binder_knsubst s (id,b) = (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b) diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli index ec7521cc..9d96467f 100644 --- a/contrib/correctness/pmisc.mli +++ b/contrib/correctness/pmisc.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmisc.mli,v 1.9.6.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pmisc.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml index f899366d..e812fa57 100644 --- a/contrib/correctness/pmlize.ml +++ b/contrib/correctness/pmlize.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmlize.ml,v 1.7.2.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pmlize.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli index 95f74ef9..1f8936f0 100644 --- a/contrib/correctness/pmlize.mli +++ b/contrib/correctness/pmlize.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmlize.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) +(* $Id: pmlize.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Past open Penv diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml index b8b39353..8f1b5946 100644 --- a/contrib/correctness/pmonad.ml +++ b/contrib/correctness/pmonad.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmonad.ml,v 1.6.16.1 2004/07/16 19:30:02 herbelin Exp $ *) +(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -76,9 +76,9 @@ let rec abstract_post ren env (e,q) = let after_id id = id_of_string ((string_of_id id) ^ "'") in let (_,go) = Peffect.get_repr e in let al = List.map (fun id -> (id,after_id id)) go in - let q = option_app (named_app (subst_in_constr al)) q in + let q = option_map (named_app (subst_in_constr al)) q in let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in - option_app (named_app (abstract tgo)) q + option_map (named_app (abstract tgo)) q (* Translation of effects types in cic types. * @@ -365,7 +365,7 @@ let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c = @(eq_phi ren'' env s svi tf) @(List.map (fun c -> CC_hole c) holes)) in - let qapp' = option_app (named_app (subst_in_constr svi)) qapp in + let qapp' = option_map (named_app (subst_in_constr svi)) qapp in let t = make_let_in ren'' env fe [] (current_vars ren''' outf,qapp') (res,tyres) (t,ty) diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli index e1400fcb..a46a040e 100644 --- a/contrib/correctness/pmonad.mli +++ b/contrib/correctness/pmonad.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pmonad.mli,v 1.1.16.1 2004/07/16 19:30:02 herbelin Exp $ *) +(* $Id: pmonad.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml index 732dcf08..669727fc 100644 --- a/contrib/correctness/pred.ml +++ b/contrib/correctness/pred.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pred.ml,v 1.6.14.1 2004/07/16 19:30:05 herbelin Exp $ *) +(* $Id: pred.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Past diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli index 2f43f4ad..a5a9549b 100644 --- a/contrib/correctness/pred.mli +++ b/contrib/correctness/pred.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pred.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *) +(* $Id: pred.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term open Past diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml index 864f6abd..4ef1982d 100644 --- a/contrib/correctness/prename.ml +++ b/contrib/correctness/prename.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: prename.ml,v 1.3.14.1 2004/07/16 19:30:05 herbelin Exp $ *) +(* $Id: prename.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Nameops diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli index 88b49d2c..1d3ab669 100644 --- a/contrib/correctness/prename.mli +++ b/contrib/correctness/prename.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: prename.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *) +(* $Id: prename.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index c1f00a3d..98d43112 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: psyntax.ml4,v 1.29.2.1 2004/07/16 19:30:05 herbelin Exp $ *) +(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -145,7 +145,7 @@ let bool_not loc a = let d = SApp ( [Variable connective_not ], [a]) in w d -let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "ZERO"] +let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "Z0"] (* program -> Coq AST *) @@ -786,7 +786,7 @@ END VERNAC COMMAND EXTEND Correctness [ "Correctness" preident(str) program(pgm) then_tac(tac) ] - -> [ Ptactic.correctness str pgm (option_app Tacinterp.interp tac) ] + -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ] END (* Show Programs *) @@ -852,7 +852,7 @@ let pr_effects x = let (ro,rw) = Peffect.get_repr x in pr_reads ro ++ pr_writes rw let pr_predicate delimited { a_name = n; a_value = c } = - (if delimited then Ppconstrnew.pr_lconstr else Ppconstrnew.pr_constr) c ++ + (if delimited then Ppconstr.pr_lconstr else Ppconstr.pr_constr) c ++ (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt()) let pr_assert b { p_name = x; p_value = v } = @@ -870,7 +870,7 @@ let pr_post_condition_opt = function let rec pr_type_v_v8 = function | Array (a,v) -> - str "array" ++ spc() ++ Ppconstrnew.pr_constr a ++ spc() ++ str "of " ++ + str "array" ++ spc() ++ Ppconstr.pr_constr a ++ spc() ++ str "of " ++ pr_type_v_v8 v | v -> pr_type_v3 v @@ -882,7 +882,7 @@ and pr_type_v3 = function pr_type_v_v8 v ++ pr_effects e ++ pr_pre_condition_list prel ++ pr_post_condition_opt postl ++ spc () ++ str "end" - | TypePure a -> Ppconstrnew.pr_constr a + | TypePure a -> Ppconstr.pr_constr a | v -> str "(" ++ pr_type_v_v8 v ++ str ")" and pr_binder = function @@ -910,9 +910,9 @@ let pr_invariant = function | Some c -> hov 2 (str "invariant" ++ spc () ++ pr_predicate false c) let pr_variant (c1,c2) = - Ppconstrnew.pr_constr c1 ++ + Ppconstr.pr_constr c1 ++ (try Constrextern.check_same_type c2 (ast_zwf_zero dummy_loc); mt () - with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstrnew.pr_constr c2)) + with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstr.pr_constr c2)) let rec pr_desc = function | Variable id -> @@ -1025,7 +1025,7 @@ let rec pr_desc = function (* Numeral or "tt": use a printer which doesn't globalize *) Ppconstr.pr_constr (Constrextern.extern_constr_in_scope false "Z_scope" (Global.env()) c) - | Debug (s,p) -> str "@" ++ Pptacticnew.qsnew s ++ pr_prog p + | Debug (s,p) -> str "@" ++ Pptactic.qsnew s ++ pr_prog p and pr_block_st = function | Label s -> hov 0 (str "label" ++ spc() ++ str s) @@ -1046,7 +1046,7 @@ and pr_prog0 b { desc = desc; pre = pre; post = post } = hov 0 (if b & post<>None then str"(" ++ pr_desc desc ++ str")" else pr_desc desc) - ++ Ppconstrnew.pr_opt pr_postcondition post) + ++ Ppconstr.pr_opt pr_postcondition post) and pr_prog x = pr_prog0 true x diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli index 18912548..c0f0990b 100644 --- a/contrib/correctness/psyntax.mli +++ b/contrib/correctness/psyntax.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: psyntax.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: psyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Pcoq open Ptype diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml index 4b22954e..babc607d 100644 --- a/contrib/correctness/ptactic.ml +++ b/contrib/correctness/ptactic.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ptactic.ml,v 1.30.2.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *) open Pp open Options @@ -51,7 +51,7 @@ let coqast_of_prog p = (* 4a. traduction type *) let ty = Pmonad.trad_ml_type_c ren env c in - deb_print (Printer.prterm_env (Global.env())) ty; + deb_print (Printer.pr_lconstr_env (Global.env())) ty; (* 4b. traduction terme (terme intermédiaire de type cc_term) *) deb_mess @@ -65,12 +65,12 @@ let coqast_of_prog p = (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++ fnl ()); let r = Pcic.rawconstr_of_prog cc in - deb_print Printer.pr_rawterm r; + deb_print Printer.pr_lrawconstr r; (* 6. résolution implicites *) deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ()); let oc = understand_gen_tcc Evd.empty (Global.env()) [] None r in - deb_print (Printer.prterm_env (Global.env())) (snd oc); + deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc); p,oc,ty,v @@ -208,8 +208,8 @@ let reduce_open_constr (em0,c) = | Cast (c',t) -> (match kind_of_term c' with | Evar (ev,_) -> - if not (Evd.in_dom em ev) then - Evd.add em ev (Evd.map em0 ev) + if not (Evd.mem em ev) then + Evd.add em ev (Evd.find em0 ev) else em | _ -> fold_constr collect em c) @@ -234,7 +234,7 @@ let correctness_hook _ ref = register pf_id None let correctness s p opttac = - Library.check_required_library ["Coq";"correctness";"Correctness"]; + Coqlib.check_required_library ["Coq";"correctness";"Correctness"]; Pmisc.reset_names(); let p,oc,cty,v = coqast_of_prog p in let env = Global.env () in @@ -248,7 +248,7 @@ let correctness s p opttac = deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ()); let oc = reduce_open_constr oc in deb_mess (str"AFTER REDUCTION:" ++ fnl ()); - deb_print (Printer.prterm_env (Global.env())) (snd oc); + deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc); let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in let tac = match opttac with | None -> tac diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli index 875e0780..87378cff 100644 --- a/contrib/correctness/ptactic.mli +++ b/contrib/correctness/ptactic.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ptactic.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: ptactic.mli 5920 2004-07-16 20:01:26Z herbelin $ *) (* The main tactic: takes a name N, a program P, creates a goal * of name N with the functional specification of P, then apply the Refine diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli index f2dc85e3..be181bcc 100644 --- a/contrib/correctness/ptype.mli +++ b/contrib/correctness/ptype.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ptype.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: ptype.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml index 9047a925..91c1f293 100644 --- a/contrib/correctness/ptyping.ml +++ b/contrib/correctness/ptyping.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ptyping.ml,v 1.7.6.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: ptyping.ml 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Util diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli index 0c0d5905..eaf548b1 100644 --- a/contrib/correctness/ptyping.mli +++ b/contrib/correctness/ptyping.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: ptyping.mli,v 1.3.6.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: ptyping.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Names open Term diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml index 48f0781a..18c3ba35 100644 --- a/contrib/correctness/putil.ml +++ b/contrib/correctness/putil.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: putil.ml,v 1.10.2.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -41,7 +41,7 @@ let anonymous x = { a_name = Anonymous; a_value = x } let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x } let force_name f x = - option_app (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x + option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x let force_post_name x = force_name post_name x @@ -143,7 +143,7 @@ let rec type_c_subst s ((id,t),e,p,q) = let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in (id, type_v_subst s t), Peffect.subst s e, List.map (pre_app (subst_in_constr s)) p, - option_app (post_app (subst_in_constr s')) q + option_map (post_app (subst_in_constr s')) q and type_v_subst s = function Ref v -> Ref (type_v_subst s v) @@ -160,7 +160,7 @@ and binder_subst s = function let rec type_c_rsubst s ((id,t),e,p,q) = (id, type_v_rsubst s t), e, List.map (pre_app (real_subst_in_constr s)) p, - option_app (post_app (real_subst_in_constr s)) q + option_map (post_app (real_subst_in_constr s)) q and type_v_rsubst s = function Ref v -> Ref (type_v_rsubst s v) @@ -231,26 +231,26 @@ and c_of_constr c = open Pp open Util -let prterm x = Printer.prterm_env (Global.env()) x +let pr_lconstr x = Printer.pr_lconstr_env (Global.env()) x let pp_pre = function [] -> (mt ()) | l -> hov 0 (str"pre " ++ prlist_with_sep (fun () -> (spc ())) - (fun x -> prterm x.p_value) l) + (fun x -> pr_lconstr x.p_value) l) let pp_post = function None -> (mt ()) - | Some c -> hov 0 (str"post " ++ prterm c.a_value) + | Some c -> hov 0 (str"post " ++ pr_lconstr c.a_value) let rec pp_type_v = function Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref") - | Array (cc,v) -> hov 0 (str"array " ++ prterm cc ++ str" of " ++ pp_type_v v) + | Array (cc,v) -> hov 0 (str"array " ++ pr_lconstr cc ++ str" of " ++ pp_type_v v) | Arrow (b,c) -> hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ pp_type_c c) - | TypePure c -> prterm c + | TypePure c -> pr_lconstr c and pp_type_c ((id,v),e,p,q) = hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ @@ -297,7 +297,7 @@ let rec pp_cc_term = function | CC_case _ -> hov 0 (str"<Case: not yet implemented>") | CC_expr c -> - hov 0 (prterm c) + hov 0 (pr_lconstr c) | CC_hole c -> - (str"(?::" ++ prterm c ++ str")") + (str"(?::" ++ pr_lconstr c ++ str")") diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli index b44774ae..6c487f3f 100644 --- a/contrib/correctness/putil.mli +++ b/contrib/correctness/putil.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: putil.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: putil.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Names diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml index 58bef673..f422c5cd 100644 --- a/contrib/correctness/pwp.ml +++ b/contrib/correctness/pwp.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pwp.ml,v 1.8.2.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -64,7 +64,7 @@ let update_post env top ef c = let force_post up env top q e = let (res,ef,p,_) = e.info.kappa in let q' = - if up then option_app (named_app (update_post env top ef)) q else q + if up then option_map (named_app (update_post env top ef)) q else q in let i = { env = e.info.env; kappa = (res,ef,p,q') } in { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i } @@ -260,7 +260,7 @@ and propagate ren p = | Apply (f,l) -> let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in if ok then - let q = option_app (named_app (real_subst_in_constr so)) qapp in + let q = option_map (named_app (real_subst_in_constr so)) qapp in post_if_none env q p else p @@ -285,7 +285,7 @@ and propagate ren p = None -> Some (anonymous s) | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name } in - let q = option_app (named_app abstract_unit) q in + let q = option_map (named_app abstract_unit) q in post_if_none env q p | SApp ([Variable id], [e1;e2]) diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli index 015031a0..4027a623 100644 --- a/contrib/correctness/pwp.mli +++ b/contrib/correctness/pwp.mli @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliâtre *) -(* $Id: pwp.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) +(* $Id: pwp.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term open Penv diff --git a/contrib/dp/TODO b/contrib/dp/TODO new file mode 100644 index 00000000..387cacdf --- /dev/null +++ b/contrib/dp/TODO @@ -0,0 +1,28 @@ + +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 +---- + +- value = Some : forall A:Set, A -> option A + + -> eta_expanse échoue sur assert false (ligne 147) + + diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml new file mode 100644 index 00000000..131dd029 --- /dev/null +++ b/contrib/dp/dp.ml @@ -0,0 +1,759 @@ +(* 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 Term +open Tacmach +open Tactics +open Tacticals +open Fol +open Names +open Nameops +open Termops +open Coqlib +open Hipattern +open Libnames +open Declarations + +let debug = ref false + +let logic_dir = ["Coq";"Logic";"Decidable"] +let coq_modules = + init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ [["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") + +(* 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 -> + 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 -> + 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 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 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 tv, env, b = decomp_type_lambdas env b in + let axioms = + (match d with + | DeclPred (id, _, []) -> + let value = tr_formula tv [] env b in + [id, Iff (Fatom (Pred (id, [])), value)] + | DeclFun (id, _, [], _) -> + 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 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 _ -> + begin match kind_of_term t with + | Case (ci, _, e, br) -> + equations_for_case env id vars tv bv ci e br + | _ -> + let p = + Fatom (Eq (App (id, fol_vars), + tr_term tv bv env t)) + in + [id, 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 = reference_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 = reference_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 b = substl (List.map mkVar rec_vars) b in + let rec_vars = List.rev rec_vars 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 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) + | 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 | CVCLite | Harvey | Zenon + +let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) + +let sprintf = Format.sprintf + +let call_simplify fwhy = + let cmd = sprintf "why --simplify %s" 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 "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" fsx + in + let out = Sys.command cmd in + let r = if out = 0 then Valid else if out = 1 then Invalid else Timeout in + if not !debug then remove_files [fwhy; fsx]; + r + +let call_zenon fwhy = + let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in + if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); + let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in + let cmd = + sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn + in + let out = Sys.command cmd in + let r = + if out = 0 then Valid + else if out = 1 then Invalid + else if out = 137 then Timeout + else anomaly ("malformed Zenon input file " ^ fznn) + in + if not !debug then remove_files [fwhy; fznn]; + r + +let call_cvcl fwhy = + let cmd = sprintf "why --cvcl %s" 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 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" fcvc + in + let out = Sys.command cmd in + let r = if out = 0 then Valid 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 %s" 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 10 rv -e\"-T 2000\" %s > %s 2>&1" 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 else Invalid + in + if not !debug then remove_files [fwhy; frv; outf]; + r + +let call_prover prover q = + let fwhy = Filename.temp_file "coq_dp" ".why" in + Dp_why.output_file fwhy q; + if !debug then ignore (Sys.command (sprintf "cat %s" fwhy)); + match prover with + | Simplify -> call_simplify fwhy + | Zenon -> call_zenon fwhy + | CVCLite -> call_cvcl fwhy + | Harvey -> call_harvey fwhy + +let dp prover gl = + 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 -> Tactics.admit_as_an_axiom gl + | Invalid -> error "Invalid" + | DontKnow -> error "Don't know" + | Timeout -> error "Timeout" + end + with NotFO -> + error "Not a first order goal" + + +let simplify = tclTHEN intros (dp Simplify) +let cvc_lite = tclTHEN intros (dp CVCLite) +let harvey = dp Harvey +let zenon = tclTHEN intros (dp Zenon) + +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 d = Axiom (id, tr_formula [] [] 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) diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli new file mode 100644 index 00000000..3dad469c --- /dev/null +++ b/contrib/dp/dp.mli @@ -0,0 +1,12 @@ + +open Libnames +open Proof_type + +val simplify : tactic +val cvc_lite : tactic +val harvey : tactic +val zenon : tactic + +val dp_hint : reference list -> unit + + diff --git a/contrib/dp/dp_cvcl.ml b/contrib/dp/dp_cvcl.ml new file mode 100644 index 00000000..05d43081 --- /dev/null +++ b/contrib/dp/dp_cvcl.ml @@ -0,0 +1,112 @@ + +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_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 "@[%s@]" id + | App (id, tl) -> + fprintf fmt "@[%s(%a)@]" 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 "@[%s@]" id + | Fatom (Pred (id, tl)) -> + fprintf fmt "@[%s(%a)@]" id print_terms tl + | Imp (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 (%s:%s): %a)@]" id t pp p + | Exists (id, t, p) -> + fprintf fmt "@[(EXISTS (%s:%s): %a)@]" id t pp p + +let rec string_of_type_list = function + | [] -> assert false + | [e] -> e + | e :: l' -> e ^ ", " ^ (string_of_type_list l') + +let print_query fmt (decls,concl) = + let print_decl = function + | DeclVar (id, [], t) -> + fprintf fmt "@[%s: %s;@]@\n" id t + | DeclVar (id, [e], t) -> + fprintf fmt "@[%s: [%s -> %s];@]@\n" + id e t + | DeclVar (id, l, t) -> + fprintf fmt "@[%s: [[%s] -> %s];@]@\n" + id (string_of_type_list l) t + | DeclPred (id, []) -> + fprintf fmt "@[%s: BOOLEAN;@]@\n" id + | DeclPred (id, [e]) -> + fprintf fmt "@[%s: [%s -> BOOLEAN];@]@\n" + id e + | DeclPred (id, l) -> + fprintf fmt "@[%s: [[%s] -> BOOLEAN];@]@\n" + id (string_of_type_list l) + | DeclType id -> + fprintf fmt "@[%s: TYPE;@]@\n" id + | Assert (id, f) -> + fprintf fmt "@[ASSERT %% %s@\n %a;@]@\n" id print_predicate f + in + List.iter print_decl decls; + fprintf fmt "QUERY %a;" print_predicate concl + +let call q = + let f = Filename.temp_file "coq_dp" ".cvc" in + let c = open_out f in + let fmt = formatter_of_out_channel c in + fprintf fmt "@[%a@]@." print_query q; + close_out c; + ignore (Sys.command (sprintf "cat %s" f)); + let cmd = + sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" f + in + prerr_endline cmd; flush stderr; + let out = Sys.command cmd in + if out = 0 then Valid else if out = 1 then Invalid else Timeout + (* TODO: effacer le fichier f et le fichier out *) + + diff --git a/contrib/dp/dp_cvcl.mli b/contrib/dp/dp_cvcl.mli new file mode 100644 index 00000000..03b6d347 --- /dev/null +++ b/contrib/dp/dp_cvcl.mli @@ -0,0 +1,4 @@ + +open Fol + +val call : query -> prover_answer diff --git a/contrib/dp/dp_simplify.ml b/contrib/dp/dp_simplify.ml new file mode 100644 index 00000000..d5376b8d --- /dev/null +++ b/contrib/dp/dp_simplify.ml @@ -0,0 +1,117 @@ + +open Format +open Fol + +let is_simplify_ident s = + let is_simplify_char = function + | 'a'..'z' | 'A'..'Z' | '0'..'9' -> true + | _ -> false + in + try + String.iter (fun c -> if not (is_simplify_char c) then raise Exit) s; true + with Exit -> + false + +let ident fmt s = + if is_simplify_ident s then fprintf fmt "%s" s else fprintf fmt "|%s|" s + +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_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 space 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 "@[(EQ %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, tl)) -> + fprintf fmt "@[(EQ (%a@ %a) |@@true|)@]" ident id print_terms tl + | Imp (a, b) -> + fprintf fmt "@[(IMPLIES@ %a@ %a)@]" pp a pp b + | And (a, b) -> + fprintf fmt "@[(AND@ %a@ %a)@]" pp a pp b + | Or (a, b) -> + fprintf fmt "@[(OR@ %a@ %a)@]" pp a pp b + | Not a -> + fprintf fmt "@[(NOT@ %a)@]" pp a + | Forall (id, _, p) -> + fprintf fmt "@[(FORALL (%a)@ %a)@]" ident id pp p + | Exists (id, _, p) -> + fprintf fmt "@[(EXISTS (%a)@ %a)@]" ident id pp p + +(** +let rec string_list l = match l with + [] -> "" + | [e] -> e + | e::l' -> e ^ " " ^ (string_list l') +**) + +let print_query fmt (decls,concl) = + let print_decl = function + | DeclVar (id, [], t) -> + fprintf fmt "@[;; %s : %s@]@\n" id t + | DeclVar (id, l, t) -> + fprintf fmt "@[;; %s : %a -> %s@]@\n" + id (print_list comma pp_print_string) l t + | DeclPred (id, []) -> + fprintf fmt "@[;; %s : BOOLEAN @]@\n" id + | DeclPred (id, l) -> + fprintf fmt "@[;; %s : %a -> BOOLEAN@]@\n" + id (print_list comma pp_print_string) l + | DeclType id -> + fprintf fmt "@[;; %s : TYPE@]@\n" id + | Assert (id, f) -> + fprintf fmt "@[(BG_PUSH ;; %s@\n %a)@]@\n" id print_predicate f + in + List.iter print_decl decls; + fprintf fmt "%a@." print_predicate concl + +let call q = + let f = Filename.temp_file "coq_dp" ".sx" in + let c = open_out f in + let fmt = formatter_of_out_channel c in + fprintf fmt "@[%a@]@." print_query q; + close_out c; + ignore (Sys.command (sprintf "cat %s" f)); + let cmd = + sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" f + in + prerr_endline cmd; flush stderr; + let out = Sys.command cmd in + if out = 0 then Valid else if out = 1 then Invalid else Timeout + (* TODO: effacer le fichier f et le fichier out *) diff --git a/contrib/dp/dp_simplify.mli b/contrib/dp/dp_simplify.mli new file mode 100644 index 00000000..03b6d347 --- /dev/null +++ b/contrib/dp/dp_simplify.mli @@ -0,0 +1,4 @@ + +open Fol + +val call : query -> prover_answer diff --git a/contrib/dp/dp_sorts.ml b/contrib/dp/dp_sorts.ml new file mode 100644 index 00000000..7dbdfa56 --- /dev/null +++ b/contrib/dp/dp_sorts.ml @@ -0,0 +1,51 @@ + +open Fol + +let term_has_sort x s = Fatom (Pred ("%sort_" ^ s, [x])) + +let has_sort x s = term_has_sort (App (x, [])) s + +let rec form = function + | True | False | Fatom _ as f -> f + | Imp (f1, f2) -> Imp (form f1, form f2) + | And (f1, f2) -> And (form f1, form f2) + | Or (f1, f2) -> Or (form f1, form f2) + | Not f -> Not (form f) + | Forall (x, ("INT" as t), f) -> Forall (x, t, form f) + | Forall (x, t, f) -> Forall (x, t, Imp (has_sort x t, form f)) + | Exists (x, ("INT" as t), f) -> Exists (x, t, form f) + | Exists (x, t, f) -> Exists (x, t, Imp (has_sort x t, form f)) + +let sort_ax = let r = ref 0 in fun () -> incr r; "sort_ax_" ^ string_of_int !r + +let hyp acc = function + | Assert (id, f) -> + (Assert (id, form f)) :: acc + | DeclVar (id, _, "INT") as d -> + d :: acc + | DeclVar (id, [], t) as d -> + (Assert (sort_ax (), has_sort id t)) :: d :: acc + | DeclVar (id, l, t) as d -> + let n = ref 0 in + let xi = + List.fold_left + (fun l t -> incr n; ("x" ^ string_of_int !n, t) :: l) [] l + in + let f = + List.fold_left + (fun f (x,t) -> if t = "INT" then f else Imp (has_sort x t, f)) + (term_has_sort + (App (id, List.rev_map (fun (x,_) -> App (x,[])) xi)) t) + xi + in + let f = List.fold_left (fun f (x,t) -> Forall (x, t, f)) f xi in + (Assert (sort_ax (), f)) :: d :: acc + | DeclPred _ as d -> + d :: acc + | DeclType t as d -> + (DeclPred ("%sort_" ^ t, [t])) :: d :: acc + +let query (hyps, f) = + let hyps' = List.fold_left hyp [] hyps in + List.rev hyps', form f + diff --git a/contrib/dp/dp_sorts.mli b/contrib/dp/dp_sorts.mli new file mode 100644 index 00000000..9e74f997 --- /dev/null +++ b/contrib/dp/dp_sorts.mli @@ -0,0 +1,4 @@ + +open Fol + +val query : query -> query diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml new file mode 100644 index 00000000..e1ddb039 --- /dev/null +++ b/contrib/dp/dp_why.ml @@ -0,0 +1,139 @@ + +(* Pretty-print PFOL (see fol.mli) in Why syntax *) + +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 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_zenon.ml b/contrib/dp/dp_zenon.ml new file mode 100644 index 00000000..57b0a44f --- /dev/null +++ b/contrib/dp/dp_zenon.ml @@ -0,0 +1,103 @@ + +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 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 "%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 + +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, tl)) -> + fprintf fmt "@[(%s@ %a)@]" id print_terms tl + | Imp (a, b) -> + fprintf fmt "@[(=>@ %a@ %a)@]" pp a pp b + | And (a, b) -> + fprintf fmt "@[(/\\@ %a@ %a)@]" pp a pp b + | Or (a, b) -> + fprintf fmt "@[(\\/@ %a@ %a)@]" pp a pp b + | Not a -> + fprintf fmt "@[(-.@ %a)@]" pp a + | Forall (id, t, p) -> + fprintf fmt "@[(A. ((%s \"%s\")@ %a))@]" id t pp p + | Exists (id, t, p) -> + fprintf fmt "@[(E. ((%s \"%s\")@ %a))@]" id t pp p + +let rec string_of_type_list = function + | [] -> "" + | e :: l' -> e ^ " -> " ^ (string_of_type_list l') + +let print_query fmt (decls,concl) = + let print_decl = function + | DeclVar (id, [], t) -> + fprintf fmt "@[;; %s: %s@]@\n" id t + | DeclVar (id, l, t) -> + fprintf fmt "@[;; %s: %s%s@]@\n" + id (string_of_type_list l) t + | DeclPred (id, l) -> + fprintf fmt "@[;; %s: %sBOOLEAN@]@\n" + id (string_of_type_list l) + | DeclType id -> + fprintf fmt "@[;; %s: TYPE@]@\n" id + | Assert (id, f) -> + fprintf fmt "@[\"%s\" %a@]@\n" id print_predicate f + in + List.iter print_decl decls; + fprintf fmt "$goal %a@." print_predicate concl + +let call q = + let f = Filename.temp_file "coq_dp" ".znn" in + let c = open_out f in + let fmt = formatter_of_out_channel c in + fprintf fmt "@[%a@]@." print_query q; + close_out c; + ignore (Sys.command (sprintf "cat %s" f)); + let cmd = + sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" f + in + prerr_endline cmd; flush stderr; + let out = Sys.command cmd in + if out = 0 then Valid + else if out = 1 then Invalid + else if out = 137 then Timeout + else Util.anomaly "malformed Zenon input file" + (* TODO: effacer le fichier f et le fichier out *) + + diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli new file mode 100644 index 00000000..03b6d347 --- /dev/null +++ b/contrib/dp/dp_zenon.mli @@ -0,0 +1,4 @@ + +open Fol + +val call : query -> prover_answer diff --git a/contrib/dp/fol.mli b/contrib/dp/fol.mli new file mode 100644 index 00000000..a85469cc --- /dev/null +++ b/contrib/dp/fol.mli @@ -0,0 +1,48 @@ + +(* 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 | Invalid | DontKnow | Timeout diff --git a/contrib/dp/g_dp.ml4 b/contrib/dp/g_dp.ml4 new file mode 100644 index 00000000..eb7fb73b --- /dev/null +++ b/contrib/dp/g_dp.ml4 @@ -0,0 +1,38 @@ +(************************************************************************) +(* 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 7165 2005-06-24 12:56:46Z coq $ *) + +open Dp + +TACTIC EXTEND Simplify + [ "simplify" ] -> [ simplify ] +END + +TACTIC EXTEND CVCLite + [ "cvcl" ] -> [ cvc_lite ] +END + +TACTIC EXTEND Harvey + [ "harvey" ] -> [ harvey ] +END + +TACTIC EXTEND Zenon + [ "zenon" ] -> [ zenon ] +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 diff --git a/contrib/dp/test2.v b/contrib/dp/test2.v new file mode 100644 index 00000000..4e933a3c --- /dev/null +++ b/contrib/dp/test2.v @@ -0,0 +1,78 @@ +Require Import ZArith. +Require Import Classical. +Require Import List. + +Open Scope list_scope. +Open Scope Z_scope. + +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. + zenon. + zenon. + (* 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/tests.v b/contrib/dp/tests.v new file mode 100644 index 00000000..52a57a0c --- /dev/null +++ b/contrib/dp/tests.v @@ -0,0 +1,220 @@ + +Require Import ZArith. +Require Import Classical. + +(* First example with the 0 and the equality translated *) + +Goal 0 = 0. +zenon. +Qed. + + +(* Examples in the Propositional Calculus + and theory of equality *) + +Parameter A C : Prop. + +Goal A -> A. +zenon. +Qed. + + +Goal A -> (A \/ C). + +zenon. +Qed. + + +Parameter x y z : Z. + +Goal x = y -> y = z -> x = z. + +zenon. +Qed. + + +Goal ((((A -> C) -> A) -> A) -> C) -> C. + +zenon. +Qed. + + +(* Arithmetic *) +Open Scope Z_scope. + +Goal 1 + 1 = 2. +simplify. +Qed. + + +Goal 2*x + 10 = 18 -> x = 4. + +simplify. +Qed. + + +(* Universal quantifier *) + +Goal (forall (x y : Z), x = y) -> 0=1. +try zenon. +simplify. +Qed. + +Goal forall (x: nat), (x + 0 = x)%nat. + +induction x0. +zenon. +zenon. +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. +cvcl. +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. + +zenon. +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 ; zenon. +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. + +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; zenon. +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. + +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. +zenon. +Qed. + + + +(* abstractions *) + +Parameter poly_f : forall A:Set, A->A. + +Goal forall x:nat, poly_f nat x = poly_f nat x. +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/extraction/common.ml b/contrib/extraction/common.ml index 8e441613..346201ec 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml,v 1.51.2.4 2005/12/16 03:07:39 letouzey Exp $ i*) +(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) open Pp open Util @@ -112,7 +112,8 @@ let contents_first_level mp = | Extraction.Term -> add false (id_of_label l)) | (_, SPBmind mib) -> Array.iter - (fun mip -> if mip.mind_sort <> (Prop Null) then begin + (fun mip -> if snd (Inductive.mind_arity mip) <> InProp + then begin add upper_type mip.mind_typename; Array.iter (add true) mip.mind_consnames end) @@ -143,7 +144,7 @@ let create_modular_renamings struc = in (* 1) creates renamings of objects *) let add upper r = - let mp = modpath (kn_of_r r) in + let mp = modpath_of_r r in let l = mp_create_modular_renamings mp in let s = modular_rename upper (id_of_global r) in global_ids := Idset.add (id_of_string s) !global_ids; @@ -184,7 +185,7 @@ let create_modular_renamings struc = List.iter contents_first_level used_modules; let used_modules' = List.rev used_modules in let needs_qualify r = - let mp = modpath (kn_of_r r) in + let mp = modpath_of_r r in if (is_modfile mp) && mp <> current_module && (clash mp [] (List.hd (get_renamings r)) used_modules') then to_qualify := Refset.add r !to_qualify @@ -239,7 +240,7 @@ let rec mp_create_mono_renamings mp = let create_mono_renamings struc = let { up = u ; down = d } = struct_get_references_list struc in let add upper r = - let mp = modpath (kn_of_r r) in + let mp = modpath_of_r r in let l = mp_create_mono_renamings mp in let mycase = if upper then uppercase_id else lowercase_id in let id = @@ -267,8 +268,6 @@ module StdParams = struct let globals () = !global_ids - (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *) - let unquote s = if lang () <> Scheme then s else @@ -285,26 +284,34 @@ module StdParams = struct let pp_global mpl r = let ls = get_renamings r in let s = List.hd ls in - let mp = modpath (kn_of_r r) in + let mp = modpath_of_r r in let ls = if mp = List.hd mpl then [s] (* simpliest situation *) - else - try (* has [mp] something in common with one of those in [mpl] ? *) - let pref = common_prefix_from_list mp mpl in - (*i TODO: possibilité de clash i*) - list_firstn ((mp_length mp)-(mp_length pref)+1) ls - with Not_found -> (* [mp] is othogonal with every element of [mp]. *) - let base = base_mp mp in - if !modular && - (at_toplevel mp) && - not (Refset.mem r !to_qualify) && - not (clash base [] s mpl) - then snd (list_sep_last ls) - else ls + else match lang () with + | Scheme -> [s] (* no modular Scheme extraction... *) + | Toplevel -> [s] (* idem *) + | Haskell -> + if !modular then + ls (* for the moment we always qualify in modular Haskell *) + else [s] + | Ocaml -> + try (* has [mp] something in common with one of those in [mpl] ? *) + let pref = common_prefix_from_list mp mpl in + (*i TODO: possibilité de clash i*) + list_firstn ((mp_length mp)-(mp_length pref)+1) ls + with Not_found -> (* [mp] is othogonal with every element of [mp]. *) + let base = base_mp mp in + if !modular && + (at_toplevel mp) && + not (Refset.mem r !to_qualify) && + not (clash base [] s mpl) + then snd (list_sep_last ls) + else ls in add_module_contents mp s; (* update the visible environment *) str (dottify ls) + (* The next function is used only in Ocaml extraction...*) let pp_module mpl mp = let ls = if !modular @@ -317,7 +324,6 @@ module StdParams = struct (*i TODO: clash possible i*) list_firstn ((mp_length mp)-(mp_length pref)) ls with Not_found -> (* [mp] is othogonal with every element of [mp]. *) - let base = base_mp mp in if !modular && (at_toplevel mp) then snd (list_sep_last ls) else ls @@ -394,15 +400,15 @@ let print_structure_to_file f prm struc = in let print_dummys = (struct_ast_search ((=) MLdummy) struc, - struct_type_search Tdummy struc, - struct_type_search Tunknown struc) + struct_type_search Mlutil.isDummy struc, + struct_type_search ((=) Tunknown) struc) in let print_magic = if lang () <> Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc in (* print the implementation *) - let cout = option_app (fun (f,_) -> open_out f) f in + let cout = option_map (fun (f,_) -> open_out f) f in let ft = match cout with | None -> !Pp_control.std_ft | Some cout -> Pp_control.with_output_to cout in diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli index 3e5efa0c..2ba51e1c 100644 --- a/contrib/extraction/common.mli +++ b/contrib/extraction/common.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.mli,v 1.19.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) +(*i $Id: common.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) open Names open Miniml diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index d725a1d7..e31b701c 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml,v 1.74.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) +(*i $Id: extract_env.ml 9486 2007-01-15 19:11:28Z letouzey $ i*) open Term open Declarations @@ -19,6 +19,7 @@ open Table open Extraction open Modutil open Common +open Mod_subst (*s Obtaining Coq environment. *) @@ -28,7 +29,7 @@ let toplevel_env () = | (_,kn), Lib.Leaf o -> let mp,_,l = repr_kn kn in let seb = match Libobject.object_tag o with - | "CONSTANT" -> SEBconst (Global.lookup_constant kn) + | "CONSTANT" -> SEBconst (Global.lookup_constant (constant_of_kn kn)) | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l))) | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn) @@ -52,19 +53,61 @@ let environment_until dir_opt = | _ -> assert false in parse (Library.loaded_libraries ()) -type visit = { mutable kn : KNset.t; mutable mp : MPset.t } -let in_kn v kn = KNset.mem kn v.kn -let in_mp v mp = MPset.mem mp v.mp - -let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp -let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn) -let visit_ref v r = visit_kn v (kn_of_r r) +(*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 + (* Thanks to C.S.C, 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 = 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 = - if Reduction.is_arity env cb.const_type then raise Impossible + 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 @@ -93,115 +136,108 @@ let factor_fix env l cb msb = labels, recd, msb'' end -let get_decl_references v d = - let f = visit_ref v in decl_iter_references f f f d - -let get_spec_references v s = - let f = visit_ref v in spec_iter_references f f f s - -let rec extract_msig env v mp = function +let rec extract_msig env mp = function | [] -> [] | (l,SPBconst cb) :: msig -> - let kn = make_kn mp empty_dirpath l in + let kn = make_con mp empty_dirpath l in let s = extract_constant_spec env kn cb in - if logical_spec s then extract_msig env v mp msig + if logical_spec s then extract_msig env mp msig else begin - get_spec_references v s; - (l,Spec s) :: (extract_msig env v mp msig) + Visit.add_spec_deps s; + (l,Spec s) :: (extract_msig env mp msig) end | (l,SPBmind cb) :: msig -> let kn = make_kn mp empty_dirpath l in let s = Sind (kn, extract_inductive env kn) in - if logical_spec s then extract_msig env v mp msig + if logical_spec s then extract_msig env mp msig else begin - get_spec_references v s; - (l,Spec s) :: (extract_msig env v mp msig) + Visit.add_spec_deps s; + (l,Spec s) :: (extract_msig env mp msig) end | (l,SPBmodule {msb_modtype=mtb}) :: msig -> -(*i let mpo = Some (MPdot (mp,l)) in i*) - (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig) + (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig) | (l,SPBmodtype mtb) :: msig -> - (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig) + (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig) -and extract_mtb env v mpo = function - | MTBident kn -> visit_kn v kn; MTident kn +and extract_mtb env mpo = function + | MTBident kn -> Visit.add_kn kn; MTident kn | MTBfunsig (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_mtb env v None mtb, - extract_mtb env' v None mtb') + MTfunsig (mbid, extract_mtb env None mtb, + extract_mtb env' None mtb') | MTBsig (msid, msig) -> let mp, msig = match mpo with | None -> MPself msid, msig | Some mp -> mp, Modops.subst_signature_msid msid mp msig in let env' = Modops.add_signature mp msig env in - MTsig (msid, extract_msig env' v mp msig) + MTsig (msid, extract_msig env' mp msig) -let rec extract_msb env v mp all = function +let rec extract_msb env mp all = function | [] -> [] | (l,SEBconst cb) :: msb -> (try let vl,recd,msb = factor_fix env l cb msb in - let vkn = Array.map (fun id -> make_kn mp empty_dirpath id) vl in - let ms = extract_msb env v mp all msb in - let b = array_exists (in_kn v) vkn in + let vc = Array.map (make_con mp empty_dirpath) vl in + let ms = extract_msb env mp all msb in + let b = array_exists Visit.needed_con vc in if all || b then - let d = extract_fixpoint env vkn recd in + let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms - else begin get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_msb env v mp all msb in - let kn = make_kn mp empty_dirpath l in - let b = in_kn v kn in + let ms = extract_msb 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 kn cb in + let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms - else begin get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SEBmind mib) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let kn = make_kn mp empty_dirpath l in - let b = in_kn v kn 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 get_decl_references v d; (l,SEdecl d) :: ms end + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SEBmodule mb) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let mp = MPdot (mp,l) in - if all || in_mp v mp then - (l,SEmodule (extract_module env v mp true mb)) :: ms + if all || Visit.needed_mp mp then + (l,SEmodule (extract_module env mp true mb)) :: ms else ms | (l,SEBmodtype mtb) :: msb -> - let ms = extract_msb env v mp all msb in + let ms = extract_msb env mp all msb in let kn = make_kn mp empty_dirpath l in - if all || in_kn v kn then - (l,SEmodtype (extract_mtb env v None mtb)) :: ms + if all || Visit.needed_kn kn then + (l,SEmodtype (extract_mtb env None mtb)) :: ms else ms -and extract_meb env v mpo all = function +and extract_meb env mpo all = function | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *) - | MEBident mp -> visit_mp v mp; MEident mp + | MEBident mp -> Visit.add_mp mp; MEident mp | MEBapply (meb, meb',_) -> - MEapply (extract_meb env v None true meb, - extract_meb env v None true meb') + MEapply (extract_meb env None true meb, + extract_meb env None true meb') | MEBfunctor (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_mtb env v None mtb, - extract_meb env' v None true meb) + MEfunctor (mbid, extract_mtb env None mtb, + extract_meb env' None true meb) | MEBstruct (msid, msb) -> let mp,msb = match mpo with | None -> MPself msid, msb | Some mp -> mp, subst_msb (map_msid msid mp) msb in let env' = add_structure mp msb env in - MEstruct (msid, extract_msb env' v mp all msb) + MEstruct (msid, extract_msb env' mp all msb) -and extract_module env v mp all mb = +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]. *) let meb = out_some mb.mod_expr in @@ -209,25 +245,21 @@ and extract_module env v mp all mb = (* Because of the "with" construct, the module type can be [MTBsig] with *) (* a msid different from the one of the module. Here is the patch. *) let mtb = replicate_msid meb mtb in - { ml_mod_expr = extract_meb env v (Some mp) all meb; - ml_mod_type = extract_mtb env v None mtb } + { ml_mod_expr = extract_meb env (Some mp) all meb; + ml_mod_type = extract_mtb env None mtb } let unpack = function MEstruct (_,sel) -> sel | _ -> assert false let mono_environment refs mpl = - let l = environment_until None in - let v = - let add_kn r = KNset.add (kn_of_r r) in - let kns = List.fold_right add_kn refs KNset.empty in - let add_mp mp = MPset.union (prefixes_mp mp) in - let mps = List.fold_right add_mp mpl MPset.empty in - let mps = KNset.fold (fun k -> add_mp (modpath k)) kns mps in - { kn = kns; mp = mps } - in + Visit.reset (); + List.iter Visit.add_ref refs; + List.iter Visit.add_mp mpl; let env = Global.env () in - List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) - (List.rev l) + let l = List.rev (environment_until None) in + List.rev_map + (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l + (*s Recursive extraction in the Coq toplevel. The vernacular command is \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env] to get the saturated environment to extract. *) @@ -248,6 +280,7 @@ let mono_extraction (f,m) qualids = let prm = {modular=false; mod_name = m; to_appear= refs} in let struc = optimize_struct prm None (mono_environment refs mps) in print_structure_to_file f prm struc; + Visit.reset (); reset_tables () let extraction_rec = mono_extraction (None,id_of_string "Main") @@ -266,16 +299,15 @@ let extraction qid = let r = Nametab.global qid in if is_custom r then msgnl (str "User defined extraction:" ++ spc () ++ - str (find_custom r) ++ fnl ()) - else begin + str (find_custom r) ++ fnl ()) + else let prm = - { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in - let kn = kn_of_r r in + { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in let struc = optimize_struct prm None (mono_environment [r] []) in let d = get_decl_in_structure r struc in - print_one_decl struc (modpath kn) d; - reset_tables () - end + print_one_decl struc (modpath_of_r r) d; + Visit.reset (); + reset_tables () (*s Extraction to a file (necessarily recursive). The vernacular command is @@ -303,32 +335,33 @@ let extraction_file f vl = let extraction_module m = check_inside_section (); check_inside_module (); - match lang () with + begin match lang () with | Toplevel -> error_toplevel () | Scheme -> error_scheme () - | _ -> - let q = snd (qualid_of_reference m) in - let mp = - try Nametab.locate_module q - with Not_found -> error_unknown_module q - in - let b = is_modfile mp in - let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in - let l = environment_until None in - let v = { kn = KNset.empty ; mp = prefixes_mp mp } in - let env = Global.env () in - let struc = - List.rev_map - (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) - (List.rev l) - in - let struc = optimize_struct prm None struc in - let struc = - let bmp = base_mp mp in - try [bmp, List.assoc bmp struc] with Not_found -> assert false - in - print_structure_to_file None prm struc; - reset_tables () + | _ -> () + end; + let q = snd (qualid_of_reference m) in + let mp = + try Nametab.locate_module q with Not_found -> error_unknown_module q + in + let b = is_modfile mp in + let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in + Visit.reset (); + Visit.add_mp mp; + let env = Global.env () in + let l = List.rev (environment_until None) in + let struc = + List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) b m)) l + in + let struc = optimize_struct prm None struc in + let struc = + let bmp = base_mp mp in + try [bmp, List.assoc bmp struc] with Not_found -> assert false + in + print_structure_to_file None prm struc; + Visit.reset (); + reset_tables () + (*s (Recursive) Extraction of a library. The vernacular command is \verb!(Recursive) Extraction Library! [M]. *) @@ -345,36 +378,38 @@ let dir_module_of_id m = let extraction_library is_rec m = check_inside_section (); check_inside_module (); - match lang () with + begin match lang () with | Toplevel -> error_toplevel () | Scheme -> error_scheme () - | _ -> - let dir_m = dir_module_of_id m in - let v = { kn = KNset.empty; mp = MPset.singleton (MPfile dir_m) } in - let l = environment_until (Some dir_m) in - let struc = - let env = Global.env () in - let select l (mp,meb) = - if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *) - then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l - else l - in - List.fold_left select [] (List.rev l) - in - let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in - let struc = optimize_struct dummy_prm None struc in - let rec print = function - | [] -> () - | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l - | (MPfile dir, sel) as e :: l -> - let short_m = snd (split_dirpath dir) in - let f = module_file_name short_m in - let prm = {modular=true;mod_name=short_m;to_appear=[]} in - print_structure_to_file (Some f) prm [e]; - print l - | _ -> assert false - in print struc; - reset_tables () + | _ -> () + end; + let dir_m = dir_module_of_id m in + Visit.reset (); + 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_meb env (Some mp) true meb)) :: l + else l + in + let struc = List.fold_left select [] l in + let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in + let struc = optimize_struct dummy_prm None struc in + let rec print = function + | [] -> () + | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l + | (MPfile dir, sel) as e :: l -> + let short_m = snd (split_dirpath dir) in + let f = module_file_name short_m in + let prm = {modular=true;mod_name=short_m;to_appear=[]} in + print_structure_to_file (Some f) prm [e]; + print l + | _ -> assert false + in + print struc; + Visit.reset (); + reset_tables () diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli index 8ce64342..a09464a1 100644 --- a/contrib/extraction/extract_env.mli +++ b/contrib/extraction/extract_env.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.mli,v 1.13.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) +(*i $Id: extract_env.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) (*s This module declares the extraction commands. *) diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 6bfe861f..6fd4a3cc 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml,v 1.136.2.4 2005/12/01 11:27:15 letouzey Exp $ i*) +(*i $Id: extraction.ml 9456 2006-12-17 20:08:38Z letouzey $ i*) (*i*) open Util @@ -35,6 +35,9 @@ exception I of inductive_info to avoid loops in [extract_inductive] *) let internal_call = ref KNset.empty +(* 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) @@ -80,6 +83,14 @@ let rec flag_of_type env t = 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. *) @@ -87,7 +98,8 @@ let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> - (is_info_scheme env t)::(type_sign (push_rel_assum (n,t) env) 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 = @@ -105,8 +117,8 @@ 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 false::s, vl - else true::s, (next_ident_away (id_of_name n) vl) :: vl + 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 = @@ -126,8 +138,8 @@ let rec nb_default_params env c = let db_from_sign s = let rec make i acc = function | [] -> acc - | true :: l -> make (i+1) (i::acc) l - | false :: l -> make i (0::acc) l + | 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 @@ -150,8 +162,8 @@ let rec db_from_ind dbmap i = let parse_ind_args si args relmax = let rec parse i j = function | [] -> Intmap.empty - | false :: s -> parse (i+1) j s - | true :: s -> + | 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) @@ -167,6 +179,7 @@ let parse_ind_args si args relmax = (* [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 c) with | App (d, args') -> @@ -183,19 +196,24 @@ let rec extract_type env db j c args = | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' (0::db) j d [] in - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (extract_type env db 0 t [], mld) + (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 - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (Tdummy, mld) - | _ -> + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (Tdummy Ktype, mld)) + | _,lvl -> let mld = extract_type env' (0::db) j d [] in - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (Tdummy, mld)) - | Sort _ -> Tdummy (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) = InProp -> Tdummy + (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 @@ -207,7 +225,7 @@ let rec extract_type env db j c args = | Const kn -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ = cb.const_type 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 @@ -222,7 +240,7 @@ let rec extract_type env db j c args = (* The more precise is [mlt'], extracted after reduction *) (* The shortest is [mlt], which use abbreviations *) (* If possible, we take [mlt], otherwise [mlt']. *) - if type_eq (mlt_env env) mlt mlt' then mlt else 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 ... *) @@ -230,7 +248,7 @@ let rec extract_type env db j c args = (* We try to reduce. *) let newc = applist (Declarations.force lbody, args) in extract_type env db j newc [])) - | Ind ((kn,i) as ip) -> + | 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 @@ -242,7 +260,7 @@ let rec extract_type env db j c args = 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 else Tunknown + 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], @@ -251,7 +269,7 @@ and extract_maybe_type env db c = and extract_type_app env db (r,s) args = let ml_args = List.fold_right - (fun (b,c) a -> if b then + (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 @@ -292,18 +310,22 @@ and extract_ind env kn = (* kn is supposed to be in long form *) with Not_found -> internal_call := KNset.add kn !internal_call; let mib = Environ.lookup_mind kn env in + (* 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 = mip0.mind_nparams in - let epar = push_rel_context mip0.mind_params_ctxt env 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 = mip.mind_sort <> (Prop Null) in - let s,v = if b then type_sign_vl env mip.mind_nf_arity else [],[] in + (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; @@ -313,7 +335,11 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_types = t }) mib.mind_packets in - add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets}; + add_ind kn + {ind_info = Standard; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = mib.mind_equiv }; (* Second pass: we extract constructors *) for i = 0 to mib.mind_ntypes - 1 do let p = packets.(i) in @@ -341,7 +367,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) 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 (type_neq (mlt_env env) Tdummy) typ 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); @@ -354,25 +380,26 @@ and extract_ind env kn = (* kn is supposed to be in long form *) 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 + | Cast(t,_,_) -> names_prod t | _ -> [] in let field_names = - list_skipn mip0.mind_nparams (names_prod mip0.mind_user_lc.(0)) in + list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in assert (List.length field_names = List.length typ); - let projs = ref KNset.empty in + 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 type_eq (mlt_env env) Tdummy typ then select_fields l typs + if isDummy (expand env typ) then select_fields l typs else - let knp = make_kn mp d (label_of_id id) in - if not (List.mem false (type_to_sign (mlt_env env) typ)) then - projs := KNset.add knp !projs; + 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 type_eq (mlt_env env) Tdummy typ then select_fields l typs + if isDummy (expand env typ) then select_fields l typs else error_record r | _ -> assert false in @@ -381,17 +408,23 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* Is this record officially declared with its projections ? *) (* If so, we use this information. *) begin try - let n = nb_default_params env mip0.mind_nf_arity in + let n = nb_default_params env + (Inductive.type_of_inductive env (mib,mip0)) + in List.iter (option_iter - (fun kn -> if KNset.mem kn !projs then add_projection n kn)) - (find_structure ip).s_PROJ + (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} in + let i = {ind_info = ind_info; + ind_nparams = npar; + ind_packets = packets; + ind_equiv = mib.mind_equiv} + in add_ind kn i; internal_call := KNset.remove kn !internal_call; i @@ -419,13 +452,13 @@ and extract_type_cons env db dbmap c i = and mlt_env env r = match r with | ConstRef kn -> (try - if not (visible_kn kn) then raise Not_found; + 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 = cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type in match cb.const_body with | None -> None | Some l_body -> @@ -439,20 +472,20 @@ and mlt_env env r = match r with | _ -> None)) | _ -> None -let type_expand env = type_expand (mlt_env env) -let type_neq env = type_neq (mlt_env env) -let type_to_sign env = type_to_sign (mlt_env env) +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_kn kn) then raise Not_found; + if not (visible_con kn) then raise Not_found; lookup_type kn with Not_found -> let typ = match opt_typ with - | None -> constant_type env kn + | 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) @@ -478,10 +511,9 @@ let rec extract_term env mle mlt c args = in extract_term env mle mlt d' [] | [] -> let env' = push_rel_assum (Name id, t) env in - let id, a = - if is_default env t - then id, new_meta () - else dummy_name, Tdummy 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 @@ -491,15 +523,16 @@ let rec extract_term env mle mlt c args = 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 - if is_default env t1 then + (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') - else - let mle' = Mlenv.push_std_type mle Tdummy in - ast_pop (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 -> @@ -515,14 +548,16 @@ let rec extract_term env mle mlt c args = 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 + | 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 = - if is_default env (type_of env c) then extract_term env mle mlt c [] - else put_magic (mlt, Tdummy) MLdummy + 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. *) @@ -540,7 +575,7 @@ and extract_app env mle mlt mk_head args = and make_mlargs env e s args typs = let l = ref s in - let keep () = match !l with [] -> true | b :: s -> l:=s; b 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)) @@ -553,19 +588,25 @@ and make_mlargs env e s args typs = 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, type_expand env t 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 metas = List.map new_meta args in + let a = new_meta () in (* We compare stored and expected types in two steps. *) (* First, can [kn] be applied to all args ? *) - let a = new_meta () in - let magic1 = needs_magic (type_recomp (metas, a), instantiation schema) in + 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 = type_to_sign env (snd schema) in + 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 @@ -580,8 +621,8 @@ and extract_cst_app env mle mlt kn args = in (* Different situations depending of the number of arguments: *) if ls = 0 then put_magic_if magic2 head - else if List.mem true s then - if la >= ls || not (List.mem false s) + 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 @@ -590,12 +631,17 @@ and extract_cst_app env mle mlt kn args = 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 + 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. *) @@ -613,12 +659,12 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = 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 (type_expand env) oi.ip_types.(j-1) in + 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 (type_neq env Tdummy) types in + 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); @@ -671,14 +717,13 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (br_size = 1); - let s = iterate (fun l -> false :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy, t)) ni.(0) mlt in + 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 params_nb = mi.ind_nparams 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. *) @@ -687,10 +732,10 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* 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 (type_expand env t) in + 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 (type_neq env Tdummy) oi.ip_types.(i) in + 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. *) @@ -746,8 +791,8 @@ let extract_std_constant env kn body typ = 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 (type_expand env (var2var' t)) in - let s = List.map (type_neq env Tdummy) l in + 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]. *) @@ -763,10 +808,12 @@ let extract_std_constant env kn body typ = let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in - let types = Array.make n Tdummy + 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 (Array.to_list vkn) in + 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 @@ -774,11 +821,12 @@ let extract_fixpoint env vkn (fi,ti,ci) = 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 = cb.const_type 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 @@ -791,12 +839,14 @@ let extract_constant env kn cb = if not (is_custom r) then warning_info_ax r; let t = snd (record_constant_type env kn (Some typ)) in Dterm (r, MLaxiom, type_expunge env t) - | (Logic,TypeScheme) -> warning_log_ax r; Dtype (r, [], Tdummy) - | (Logic,Default) -> warning_log_ax r; Dterm (r, MLdummy, Tdummy)) + | (Logic,TypeScheme) -> + warning_log_ax r; Dtype (r, [], Tdummy Ktype) + | (Logic,Default) -> + warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother)) | Some body -> (match flag_of_type env typ with - | (Logic, Default) -> Dterm (r, MLdummy, Tdummy) - | (Logic, TypeScheme) -> Dtype (r, [], Tdummy) + | (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) @@ -808,10 +858,10 @@ let extract_constant env kn cb = let extract_constant_spec env kn cb = let r = ConstRef kn in - let typ = cb.const_type 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) - | (Logic, Default) -> Sval (r, Tdummy) + | (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 @@ -827,7 +877,7 @@ let extract_constant_spec env kn cb = let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; - let f l = List.filter (type_neq env Tdummy) l in + 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 @@ -846,7 +896,7 @@ let extract_declaration env r = match r with type kind = Logical | Term | Type let constant_kind env cb = - match flag_of_type env cb.const_type with + match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with | (Logic,_) -> Logical | (Info,TypeScheme) -> Type | (Info,Default) -> Term @@ -854,19 +904,19 @@ let constant_kind env cb = (*s Is a [ml_decl] logical ? *) let logical_decl = function - | Dterm (_,MLdummy,Tdummy) -> true - | Dtype (_,[],Tdummy) -> true + | Dterm (_,MLdummy,Tdummy _) -> true + | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> (array_for_all ((=) MLdummy) av) && - (array_for_all ((=) Tdummy) tv) + (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 + | 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 index fc5782c9..1dfd7e1a 100644 --- a/contrib/extraction/extraction.mli +++ b/contrib/extraction/extraction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.mli,v 1.27.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) +(*i $Id: extraction.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*) (*s Extraction from Coq terms to Miniml. *) @@ -17,12 +17,12 @@ open Environ open Libnames open Miniml -val extract_constant : env -> kernel_name -> constant_body -> ml_decl +val extract_constant : env -> constant -> constant_body -> ml_decl -val extract_constant_spec : env -> kernel_name -> constant_body -> ml_spec +val extract_constant_spec : env -> constant -> constant_body -> ml_spec val extract_fixpoint : - env -> kernel_name array -> (constr, types) prec_declaration -> ml_decl + env -> constant array -> (constr, types) prec_declaration -> ml_decl val extract_inductive : env -> kernel_name -> ml_ind diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 index 33a6117d..13b29c7b 100644 --- a/contrib/extraction/g_extraction.ml4 +++ b/contrib/extraction/g_extraction.ml4 @@ -15,10 +15,7 @@ open Pcoq open Genarg open Pp -let pr_mlname _ _ s = - spc () ++ - (if !Options.v7 && not (Options.do_translate()) then qs s - else Pptacticnew.qsnew s) +let pr_mlname _ _ _ s = spc () ++ qs s ARGUMENT EXTEND mlname TYPED AS string @@ -37,21 +34,6 @@ VERNAC ARGUMENT EXTEND language | [ "Toplevel" ] -> [ Toplevel ] END -(* Temporary for translator *) -if !Options.v7 then - let pr_language _ _ = function - | Ocaml -> str " Ocaml" - | Haskell -> str " Haskell" - | Scheme -> str " Scheme" - | Toplevel -> str " Toplevel" - in - let globwit_language = Obj.magic rawwit_language in - let wit_language = Obj.magic rawwit_language in - Pptactic.declare_extra_genarg_pprule true - (rawwit_language, pr_language) - (globwit_language, pr_language) - (wit_language, pr_language); - (* Extraction commands *) VERNAC COMMAND EXTEND Extraction diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index 3834fe81..f924396c 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml,v 1.40.2.5 2005/12/16 04:11:28 letouzey Exp $ i*) +(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -106,7 +106,7 @@ let rec pp_type par vl t = | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy -> str "()" + | Tdummy _ -> str "()" | Tunknown -> str "()" | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" in @@ -210,7 +210,7 @@ and pp_function env f t = (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 () @@ -240,11 +240,11 @@ let pp_one_ind ip pl cv = prlist_with_sep (fun () -> (str " ")) (pp_type true pl) l)) in - str (if cv = [||] then "type " else "data ") ++ + str (if Array.length cv = 0 then "type " else "data ") ++ pp_global (IndRef ip) ++ str " " ++ prlist_with_sep (fun () -> str " ") pr_lower_id pl ++ (if pl = [] then mt () else str " ") ++ - if cv = [||] then str "= () -- empty inductive" + if Array.length cv = 0 then str "= () -- empty inductive" else (v 0 (str "= " ++ prvect_with_sep (fun () -> fnl () ++ str " | ") pp_constructor @@ -289,12 +289,16 @@ let pp_decl mpl = else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global r ++ spc () ++ st) ++ fnl () ++ fnl () - | Dfix (rv, defs,_) -> - let ppv = Array.map pp_global rv in - prlist_with_sep (fun () -> fnl () ++ fnl ()) - (fun (pi,ti) -> pp_function (empty_env ()) pi ti) - (List.combine (Array.to_list ppv) (Array.to_list defs)) - ++ fnl () ++ fnl () + | Dfix (rv, defs, typs) -> + let max = Array.length rv in + let rec iter i = + if i = max then mt () + else + let e = pp_global rv.(i) in + e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () + ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ fnl () + ++ iter (i+1) + in iter 0 | Dterm (r, a, t) -> if is_inline_custom r then mt () else diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli index 822444bd..106f7868 100644 --- a/contrib/extraction/haskell.mli +++ b/contrib/extraction/haskell.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.mli,v 1.15.6.2 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: haskell.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) open Pp open Names diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli index 7c18f9f5..3b4146f8 100644 --- a/contrib/extraction/miniml.mli +++ b/contrib/extraction/miniml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: miniml.mli,v 1.46.2.3 2005/12/01 16:43:58 letouzey Exp $ i*) +(*i $Id: miniml.mli 9456 2006-12-17 20:08:38Z letouzey $ i*) (*s Target language for extraction: a core ML called MiniML. *) @@ -18,11 +18,18 @@ 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, - and [true] means that the argument is to be kept. *) +(* Convention: outmost lambda/product gives the head of the list. *) -type signature = bool list +type signature = sign list (*s ML type expressions. *) @@ -32,7 +39,7 @@ type ml_type = | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) - | Tdummy + | Tdummy of kill_reason | Tunknown | Taxiom @@ -72,7 +79,9 @@ type ml_ind_packet = { type ml_ind = { ind_info : inductive_info; ind_nparams : int; - ind_packets : ml_ind_packet array } + ind_packets : ml_ind_packet array; + ind_equiv : kernel_name option +} (*s ML terms. *) diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index c01766b0..6bfedce5 100644 --- a/contrib/extraction/mlutil.ml +++ b/contrib/extraction/mlutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.ml,v 1.104.2.3 2005/12/01 16:28:04 letouzey Exp $ i*) +(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*) (*i*) open Pp @@ -111,7 +111,7 @@ let rec mgu = function List.iter mgu (List.combine l l') | Tvar i, Tvar j when i = j -> () | Tvar' i, Tvar' j when i = j -> () - | Tdummy, Tdummy -> () + | Tdummy _, Tdummy _ -> () | Tunknown, Tunknown -> () | _ -> raise Impossible @@ -209,8 +209,8 @@ end (*s Does a section path occur in a ML type ? *) let rec type_mem_kn kn = function - | Tmeta _ -> assert false - | Tglob (r,l) -> (kn_of_r r) = kn || List.exists (type_mem_kn kn) l + | 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 @@ -218,7 +218,7 @@ let rec type_mem_kn kn = function let type_maxvar t = let rec parse n = function - | Tmeta _ -> assert false + | 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 @@ -228,7 +228,7 @@ let type_maxvar t = (*s From [a -> b -> c] to [[a;b],c]. *) let rec type_decomp = function - | Tmeta _ -> assert false + | Tmeta {contents = Some t} -> type_decomp t | Tarr (a,b) -> let l,h = type_decomp b in a::l, h | a -> [],a @@ -241,7 +241,7 @@ let rec type_recomp (l,t) = match l with (*s Translating [Tvar] to [Tvar'] to avoid clash. *) let rec var2var' = function - | Tmeta _ -> assert false + | 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) @@ -254,14 +254,14 @@ type abbrev_map = global_reference -> ml_type option let type_expand env t = let rec expand = function - | Tmeta _ -> assert false - | Tglob (r,l) as t -> + | 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 expand t + in if Table.type_expand () then expand t else t (*s Idem, but only at the top level of implications. *) @@ -269,7 +269,7 @@ let is_arrow = function Tarr _ -> true | _ -> false let type_weak_expand env t = let rec expand = function - | Tmeta _ -> assert false + | Tmeta {contents = Some t} -> expand t | Tglob (r,l) as t -> (match env r with | Some mlt -> @@ -280,34 +280,39 @@ let type_weak_expand env t = | a -> a in expand t -(*s Equality over ML types modulo delta-reduction *) - -let type_eq env t t' = (type_expand env t = type_expand env t') - -let type_neq env t t' = (type_expand env t <> type_expand env t') - (*s Generating a signature from a ML type. *) -let type_to_sign env t = +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 _ -> assert false - | Tarr (a,b) -> (Tdummy <> a) :: (f b) + | 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_sign env t in + let s = type_to_signature env t in if s = [] then t - else if List.mem true s then + else if List.mem Keep s then let rec f t s = - if List.mem false s then + if List.exists isKill s then match t with - | Tmeta _ -> assert false + | Tmeta {contents = Some t} -> f t s | Tarr (a,b) -> let t = f b (List.tl s) in - if List.hd s then Tarr (a, t) else t + 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 @@ -315,7 +320,9 @@ let type_expunge env t = | _ -> assert false else t in f t s - else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) + 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. *) @@ -377,7 +384,7 @@ let ast_iter f = function | 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 as a -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) @@ -535,8 +542,8 @@ let rec dummy_lams a = function let rec anonym_or_dummy_lams a = function | [] -> a - | true :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) - | false :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s) + | 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. *) @@ -549,8 +556,8 @@ let rec eta_args n = let rec eta_args_sign n = function | [] -> [] - | true :: s -> (MLrel n) :: (eta_args_sign (n-1) s) - | false :: s -> eta_args_sign (n-1) s + | 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)] *) @@ -594,11 +601,12 @@ let rec linear_beta_red a t = match a,t with linear beta reductions at modified positions. *) let rec ast_glob_subst s t = match t with - | MLapp ((MLglob (ConstRef kn)) as f, a) -> + | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> let a = List.map (ast_glob_subst s) a in - (try linear_beta_red a (KNmap.find kn s) + (try linear_beta_red a (Refmap.find refe s) with Not_found -> MLapp (f, a)) - | MLglob (ConstRef kn) -> (try KNmap.find kn s with Not_found -> t) + | MLglob ((ConstRef kn) as refe) -> + (try Refmap.find refe s with Not_found -> t) | _ -> ast_map (ast_glob_subst s) t @@ -653,7 +661,7 @@ let check_generalizable_case unsafe br = (*s Do all branches correspond to the same thing? *) let check_constant_case br = - if br = [||] then raise Impossible; + if Array.length br = 0 then raise Impossible; let (r,l,t) = br.(0) in let n = List.length l in if ast_occurs_itvl 1 n t then raise Impossible; @@ -818,33 +826,33 @@ let rec post_simpl = function (*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 [true] +(*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 - | true::l,a::args -> a :: (select_via_bl l args) - | false::l,a::args -> select_via_bl l 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 bool list [bl]. +(*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. [true] means "to keep" and [false] means "to eliminate". + 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 then (n+1) else n) 0 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 | [] -> () - | true :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l - | false :: l -> parse_ids (i+1) j l + | 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 @@ -855,8 +863,8 @@ let kill_some_lams bl (ids,c) = let kill_dummy_lams c = let ids,c = collect_lams c in - let bl = List.map ((<>) dummy_name) ids in - if (List.mem true bl) && (List.mem false bl) then + 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 @@ -864,7 +872,7 @@ let kill_dummy_lams c = (*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 = [true;true;false;true]] then the output is : +(* 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) = @@ -872,13 +880,13 @@ let eta_expansion_sign s (ids,c) = | [] -> let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) - | true :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | false :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l + | 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 [false] in [s]. *) + corresponding to [Del] in [s]. *) let case_expunge s e = let m = List.length s in @@ -890,13 +898,14 @@ let case_expunge s e = (*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 dummy. *) + 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 = [] then MLlam (dummy_name, ast_lift 1 c) + 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 @@ -905,7 +914,7 @@ let term_expunge s (ids,c) = let kill_dummy_args ids t0 t = let m = List.length ids in - let bl = List.rev_map ((<>) dummy_name) 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 @@ -972,7 +981,8 @@ 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 -> v.(j-1)<-(-i-1) + | 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 @@ -999,8 +1009,7 @@ let optimize_fix a = -> a' | MLfix(_,[|f|],[|c|]) -> (try general_optimize_fix f ids n args m c - with Impossible -> - named_lams ids (MLapp (MLfix (0,[|f|],[|c|]),args))) + with Impossible -> a) | _ -> a) | _ -> a @@ -1117,7 +1126,7 @@ let inline_test t = let manual_inline_list = let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in - List.map (fun s -> (make_kn mp empty_dirpath (mk_label s))) + 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" ] diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli index eaf38778..a55caaf2 100644 --- a/contrib/extraction/mlutil.mli +++ b/contrib/extraction/mlutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.mli,v 1.47.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) +(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) open Util open Names @@ -62,13 +62,15 @@ 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_eq : abbrev_map -> ml_type -> ml_type -> bool -val type_neq : abbrev_map -> ml_type -> ml_type -> bool -val type_to_sign : abbrev_map -> ml_type -> bool list +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 case_expunge : bool list -> ml_ast -> identifier list * ml_ast -val term_expunge : bool list -> identifier list * ml_ast -> ml_ast +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 @@ -86,9 +88,9 @@ 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 -> bool list -> ml_ast +val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast -val eta_args_sign : int -> bool list -> ml_ast list +val eta_args_sign : int -> signature -> ml_ast list (*s Utility functions over ML terms. *) @@ -101,7 +103,7 @@ 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 KNmap.t -> 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 diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index 54f0c992..c9d4e237 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml,v 1.7.2.4 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: modutil.ml 9456 2006-12-17 20:08:38Z letouzey $ i*) open Names open Declarations @@ -16,6 +16,7 @@ open Util open Miniml open Table open Mlutil +open Mod_subst (*S Functions upon modules missing in [Modops]. *) @@ -25,8 +26,9 @@ open Mlutil let add_structure mp msb env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in + let con = make_con mp empty_dirpath l in match elem with - | SEBconst cb -> Environ.add_constant kn cb env + | SEBconst cb -> Environ.add_constant con cb env | SEBmind mib -> Environ.add_mind kn mib env | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env | SEBmodtype mtb -> Environ.add_modtype kn mtb env @@ -116,8 +118,15 @@ let rec parse_labels ll = function let labels_of_mp mp = parse_labels [] mp -let labels_of_kn kn = - let mp,_,l = repr_kn kn in parse_labels [l] 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 @@ -176,7 +185,7 @@ let ast_iter_references do_term do_cons do_type a = | MLcons (i,r,_) -> if lang () = Ocaml then record_iter_references do_term i; do_cons r - | MLcase (i,_,v) as a -> + | MLcase (i,_,v) -> if lang () = Ocaml then record_iter_references do_term i; Array.iter (fun (r,_,_) -> do_cons r) v | _ -> () @@ -186,7 +195,10 @@ 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); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types + do_type (IndRef ip); + if lang () = Ocaml then + option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv; + 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 @@ -243,40 +255,40 @@ let struct_get_references_list struc = exception Found -let rec ast_search t a = - if t a then raise Found else ast_iter (ast_search t) a +let rec ast_search f a = + if f a then raise Found else ast_iter (ast_search f) a -let decl_ast_search t = function - | Dterm (_,a,_) -> ast_search t a - | Dfix (_,c,_) -> Array.iter (ast_search t) c +let decl_ast_search f = function + | Dterm (_,a,_) -> ast_search f a + | Dfix (_,c,_) -> Array.iter (ast_search f) c | _ -> () -let struct_ast_search t s = - try struct_iter (decl_ast_search t) (fun _ -> ()) s; false +let struct_ast_search f s = + try struct_iter (decl_ast_search f) (fun _ -> ()) s; false with Found -> true -let rec type_search t = function - | Tarr (a,b) -> type_search t a; type_search t b - | Tglob (r,l) -> List.iter (type_search t) l - | u -> if t = u then raise Found +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 t = function +let decl_type_search f = function | Dind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p - | Dterm (_,_,u) -> type_search t u - | Dfix (_,_,v) -> Array.iter (type_search t) v - | Dtype (_,_,u) -> type_search t u + (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 t = function +let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p - | Stype (_,_,ot) -> option_iter (type_search t) ot - | Sval (_,u) -> type_search t u + (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 t s = - try struct_iter (decl_type_search t) (spec_type_search t) s; false +let struct_type_search f s = + try struct_iter (decl_type_search f) (spec_type_search f) s; false with Found -> true @@ -307,8 +319,7 @@ let signature_of_structure s = let get_decl_in_structure r struc = try - let kn = kn_of_r r in - let base_mp,ll = labels_of_kn kn in + 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 @@ -336,27 +347,27 @@ let get_decl_in_structure r struc = let dfix_to_mlfix rv av i = let rec make_subst n s = if n < 0 then s - else make_subst (n-1) (KNmap.add (kn_of_r rv.(n)) (n+1) s) + else make_subst (n-1) (Refmap.add rv.(n) (n+1) s) in - let s = make_subst (Array.length rv - 1) KNmap.empty + let s = make_subst (Array.length rv - 1) Refmap.empty in let rec subst n t = match t with - | MLglob (ConstRef kn) -> - (try MLrel (n + (KNmap.find kn s)) with Not_found -> t) + | 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 (kn_of_r r))) rv 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 prm s = function | [] -> [] - | (Dtype (r,_,Tdummy) | Dterm(r,MLdummy,_)) as d :: l -> + | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l -> if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm 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 := KNmap.add (kn_of_r r) t !s; + if i then s := Refmap.add r t !s; if not i || prm.modular || List.mem r prm.to_appear then let d = match optimize_fix t with @@ -370,10 +381,9 @@ let rec optim prm s = function let rec optim_se top prm s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> - let kn = kn_of_r r in let a = normalize (ast_glob_subst !s a) in let i = inline r a in - if i then s := KNmap.add kn a !s; + if i then s := Refmap.add r a !s; if top && i && not prm.modular && not (List.mem r prm.to_appear) then optim_se top prm s lse else @@ -389,7 +399,7 @@ let rec optim_se top prm s = function let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body - then s := KNmap.add (kn_of_r rv.(i)) (dfix_to_mlfix rv av i) !s + then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s else all := false done; if !all && top && not prm.modular @@ -408,6 +418,6 @@ and optim_me prm s = function | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s me) let optimize_struct prm before struc = - let subst = ref (KNmap.empty : ml_ast KNmap.t) in + let subst = ref (Refmap.empty : ml_ast Refmap.t) in option_iter (fun l -> ignore (optim prm subst l)) before; List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli index 7f8c4113..115a42ca 100644 --- a/contrib/extraction/modutil.mli +++ b/contrib/extraction/modutil.mli @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli,v 1.2.2.2 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) open Names open Declarations open Environ open Libnames open Miniml +open Mod_subst (*s Functions upon modules missing in [Modops]. *) @@ -43,7 +44,7 @@ val add_labels_mp : module_path -> label list -> module_path (*s Functions upon ML modules. *) val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool -val struct_type_search : ml_type -> ml_structure -> bool +val struct_type_search : (ml_type -> bool) -> ml_structure -> bool type do_ref = global_reference -> unit diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index ff9cfd21..35f9a83c 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml,v 1.100.2.6 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: ocaml.ml 9472 2007-01-05 15:49:32Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -196,7 +196,7 @@ let rec pp_type par vl t = | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy -> str "__" + | Tdummy _ -> str "__" | Tunknown -> str "__" in hov 0 (pp_rec par t) @@ -264,7 +264,6 @@ let rec pp_expr par env args = let tuple = pp_tuple (pp_expr true env []) args' in pp_par par (pp_global r ++ spc () ++ tuple) | MLcase (i, t, pv) -> - let r,_,_ = pv.(0) in let expr = if i = Coinductive then (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) else @@ -344,13 +343,9 @@ and pp_pat env i pv = and pp_function env f t = let bl,t' = collect_lams t in let bl,env' = push_vars bl env in - let is_function pv = - let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in - not (List.exists (fun (k,t0) -> ast_occurs (k+1) t0) ktl) - in match t' with - | MLcase(i,MLrel 1,pv) when i=Standard -> - if is_function pv then + | MLcase(i,MLrel 1,pv) when i=Standard -> + if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then (f ++ pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (str " | " ++ pp_pat env' i pv)) @@ -359,7 +354,6 @@ and pp_function env f t = str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ v 0 (str " | " ++ pp_pat env' i pv)) - | _ -> (f ++ pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t')) @@ -398,7 +392,14 @@ let rec pp_Dfix init i ((rv,c,t) as fix) = (*s Pretty-printing of inductive types declaration. *) -let pp_one_ind prefix ip pl cv = +let pp_equiv param_list = function + | None -> mt () + | Some ip_equiv -> + str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv) + +let pp_comment s = str "(* " ++ s ++ str " *)" + +let pp_one_ind prefix ip ip_equiv pl cv = let pl = rename_tvars keywords pl in let pp_constructor (r,l) = hov 2 (str " | " ++ pp_global r ++ @@ -408,13 +409,12 @@ let pp_one_ind prefix ip pl cv = prlist_with_sep (fun () -> spc () ++ str "* ") (pp_type true pl) l)) in - pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ - if cv = [||] then str " unit (* empty inductive *)" + pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ + pp_equiv pl ip_equiv ++ str " =" ++ + if Array.length cv = 0 then str " unit (* empty inductive *)" else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor (Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv)) -let pp_comment s = str "(* " ++ s ++ str " *)" - let pp_logical_ind packet = pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ fnl () ++ pp_comment (str "with constructors : " ++ @@ -428,10 +428,11 @@ let pp_singleton kn packet = pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) -let pp_record kn projs packet = +let pp_record kn projs ip_equiv packet = let l = List.combine projs packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in - str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++ + str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ + pp_equiv pl ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) ++ str " }" @@ -440,17 +441,20 @@ let pp_coind ip pl = let r = IndRef ip in let pl = rename_tvars keywords pl in pp_parameters pl ++ pp_global r ++ str " = " ++ - pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" + pp_parameters pl ++ str "__" ++ pp_global r ++ 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 rec pp i = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in + let ip_equiv = option_map (fun kn -> (kn,i)) ind.ind_equiv in let p = ind.ind_packets.(i) in - if is_custom (IndRef (kn,i)) then pp (i+1) + 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) @@ -459,8 +463,8 @@ let pp_ind co kn ind = begin init := (fnl () ++ str "and "); s ++ - (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ()) - ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++ + (if co then pp_coind ip p.ip_vars else mt ()) + ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++ pp (i+1) end end @@ -474,19 +478,21 @@ 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_packets.(0) + | Record projs -> + let ip_equiv = option_map (fun kn -> (kn,0)) i.ind_equiv in + pp_record kn projs ip_equiv i.ind_packets.(0) | Standard -> pp_ind false kn i let pp_decl mpl = local_mpl := mpl; function - | Dind (kn,i) as d -> pp_mind kn i + | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> if is_inline_custom r then failwith "empty phrase" else - let pp_r = pp_global r in + let pp_r = pp_global r in let l = rename_tvars keywords l in - let ids, def = try + let ids, def = try let ids,s = find_type_custom r in pp_string_parameters ids, str "=" ++ spc () ++ str s with not_found -> @@ -580,7 +586,7 @@ let rec pp_structure_elem mpl = function | (l,SEmodule m) -> hov 1 (str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ - (* if you want signatures everywhere: *) + (*i if you want signatures everywhere: i*) (*i str " :" ++ fnl () ++ i*) (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*) str " = " ++ diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli index 5015a50d..8c521ccd 100644 --- a/contrib/extraction/ocaml.mli +++ b/contrib/extraction/ocaml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.mli,v 1.26.6.3 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: ocaml.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) (*s Some utility functions to be reused in module [Haskell]. *) diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml index 4a881da2..7004a202 100644 --- a/contrib/extraction/scheme.ml +++ b/contrib/extraction/scheme.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.ml,v 1.9.2.5 2005/12/16 03:07:39 letouzey Exp $ i*) +(*i $Id: scheme.ml 7651 2005-12-16 03:19:20Z letouzey $ i*) (*s Production of Scheme syntax. *) diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli index 2a828fb9..ef4a3a63 100644 --- a/contrib/extraction/scheme.mli +++ b/contrib/extraction/scheme.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.mli,v 1.6.6.2 2005/12/01 17:01:22 letouzey Exp $ i*) +(*i $Id: scheme.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) (*s Some utility functions to be reused in module [Haskell]. *) diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 9d73d13f..b1a3cb31 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml,v 1.35.2.2 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: table.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) open Names open Term @@ -22,10 +22,23 @@ open Miniml (*S Utilities concerning [module_path] and [kernel_names] *) -let kn_of_r r = match r with - | ConstRef kn -> kn - | IndRef (kn,_) -> kn - | ConstructRef ((kn,_),_) -> kn +let occur_kn_in_ref kn = + function + | IndRef (kn',_) + | ConstructRef ((kn',_),_) -> kn = kn' + | ConstRef _ -> false + | VarRef _ -> assert false + +let modpath_of_r r = match r with + | ConstRef kn -> con_modpath kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> modpath kn + | VarRef _ -> assert false + +let label_of_r r = match r with + | ConstRef kn -> con_label kn + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> label kn | VarRef _ -> assert false let current_toplevel () = fst (Lib.current_prefix ()) @@ -45,21 +58,22 @@ 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)) (*S The main tables: constants, inductives, records, ... *) (*s Constants tables. *) -let terms = ref (KNmap.empty : ml_decl KNmap.t) -let init_terms () = terms := KNmap.empty -let add_term kn d = terms := KNmap.add kn d !terms -let lookup_term kn = KNmap.find kn !terms +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 (KNmap.empty : ml_schema KNmap.t) -let init_types () = types := KNmap.empty -let add_type kn s = types := KNmap.add kn s !types -let lookup_type kn = KNmap.find kn !types +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. *) @@ -70,22 +84,22 @@ let lookup_ind kn = KNmap.find kn !inductives (*s Recursors table. *) -let recursors = ref KNset.empty -let init_recursors () = recursors := KNset.empty +let recursors = ref Cset.empty +let init_recursors () = recursors := Cset.empty let add_recursors env kn = - let make_kn id = make_kn (modpath kn) empty_dirpath (label_of_id id) in + 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 := KNset.add kn_rec (KNset.add kn_rect !recursors)) + recursors := Cset.add kn_rec (Cset.add kn_rect !recursors)) mib.mind_packets let is_recursor = function - | ConstRef kn -> KNset.mem kn !recursors + | ConstRef kn -> Cset.mem kn !recursors | _ -> false (*s Record tables. *) @@ -109,7 +123,7 @@ let reset_tables () = done before. *) let id_of_global = function - | ConstRef kn -> let _,_,l = repr_kn kn in id_of_label l + | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l | IndRef (kn,i) -> (lookup_ind kn).ind_packets.(i).ip_typename | ConstructRef ((kn,i),j) -> (lookup_ind kn).ind_packets.(i).ip_consnames.(j-1) | _ -> assert false @@ -126,16 +140,14 @@ let error_axiom_scheme r i = str " type variable(s).") let warning_info_ax r = - Options.if_verbose msg_warning - (str "You must realize axiom " ++ - pr_global r ++ str " in the extracted code.") + msg_warning (str "You must realize axiom " ++ + pr_global r ++ str " in the extracted code.") let warning_log_ax r = - Options.if_verbose msg_warning - (str "This extraction depends on logical axiom" ++ spc () ++ - pr_global r ++ str "." ++ spc() ++ - str "Having false logical axiom in the environment when extracting" ++ - spc () ++ str "may lead to incorrect or non-terminating ML terms.") + msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ + pr_global r ++ str "." ++ spc() ++ + str "Having false logical axiom in the environment when extracting" ++ + spc () ++ str "may lead to incorrect or non-terminating ML terms.") let check_inside_module () = try @@ -207,6 +219,18 @@ let _ = declare_bool_option 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 *) @@ -311,14 +335,22 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) -let (inline_extraction,_) = +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 (subst_global s) l))) } + (*CSC: The following substitution may istantiate a realized parameter. + The right solution would be to make the substitution erase the + realizer from the table. However, this is not allowed by Coq. + In this particular case, though, keeping the realizer is place seems + to be harmless since the current code looks for a realizer only + when the constant is a parameter. However, if this behaviour changes + subtle bugs can happear in the future. *) + 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); @@ -409,7 +441,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Environ.constant_type env kn 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 diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index 6160452a..66662138 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.mli,v 1.25.2.2 2005/11/29 21:40:51 letouzey Exp $ i*) +(*i $Id: table.mli 6441 2004-12-09 02:27:09Z letouzey $ i*) open Names open Libnames @@ -35,7 +35,9 @@ val check_inside_section : unit -> unit (*s utilities concerning [module_path]. *) -val kn_of_r : global_reference -> kernel_name +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 @@ -43,14 +45,15 @@ val is_modfile : module_path -> bool val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool val visible_kn : kernel_name -> bool +val visible_con : constant -> bool (*s Some table-related operations *) -val add_term : kernel_name -> ml_decl -> unit -val lookup_term : kernel_name -> ml_decl +val add_term : constant -> ml_decl -> unit +val lookup_term : constant -> ml_decl -val add_type : kernel_name -> ml_schema -> unit -val lookup_type : kernel_name -> ml_schema +val add_type : constant -> ml_schema -> unit +val lookup_type : constant -> ml_schema val add_ind : kernel_name -> ml_ind -> unit val lookup_ind : kernel_name -> ml_ind @@ -58,7 +61,7 @@ val lookup_ind : kernel_name -> ml_ind val add_recursors : Environ.env -> kernel_name -> unit val is_recursor : global_reference -> bool -val add_projection : int -> kernel_name -> unit +val add_projection : int -> constant -> unit val is_projection : global_reference -> bool val projection_arity : global_reference -> int @@ -68,6 +71,10 @@ val reset_tables : unit -> unit val auto_inline : unit -> bool +(*s TypeExpand parameter *) + +val type_expand : unit -> bool + (*s Optimize parameter *) type opt_flag = diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend index 641b50a7..31d46eeb 100644 --- a/contrib/extraction/test/.depend +++ b/contrib/extraction/test/.depend @@ -2,110 +2,318 @@ theories/Arith/arith.cmo: theories/Arith/arith.cmi theories/Arith/arith.cmx: theories/Arith/arith.cmi theories/Arith/between.cmo: theories/Arith/between.cmi theories/Arith/between.cmx: theories/Arith/between.cmi -theories/Arith/bool_nat.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ +theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/bool_nat.cmi -theories/Arith/bool_nat.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Arith/peano_dec.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ +theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Arith/peano_dec.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/bool_nat.cmi -theories/Arith/compare_dec.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/compare_dec.cmi -theories/Arith/compare_dec.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/compare_dec.cmi -theories/Arith/compare.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi +theories/Arith/compare.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/compare.cmi -theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/compare.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/compare.cmi -theories/Arith/div2.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi \ - theories/Init/specif.cmi theories/Arith/div2.cmi -theories/Arith/div2.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmx \ - theories/Init/specif.cmx theories/Arith/div2.cmi -theories/Arith/eqNat.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/eqNat.cmi -theories/Arith/eqNat.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/eqNat.cmi -theories/Arith/euclid.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/div2.cmi +theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/div2.cmi +theories/Arith/eqNat.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/eqNat.cmi +theories/Arith/eqNat.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/eqNat.cmi +theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/euclid.cmi -theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/euclid.cmi -theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/even.cmi -theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/even.cmi -theories/Arith/factorial.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Arith/factorial.cmi -theories/Arith/factorial.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Arith/factorial.cmi +theories/Arith/factorial.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/factorial.cmi +theories/Arith/factorial.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/factorial.cmi theories/Arith/gt.cmo: theories/Arith/gt.cmi theories/Arith/gt.cmx: theories/Arith/gt.cmi theories/Arith/le.cmo: theories/Arith/le.cmi theories/Arith/le.cmx: theories/Arith/le.cmi theories/Arith/lt.cmo: theories/Arith/lt.cmi theories/Arith/lt.cmx: theories/Arith/lt.cmi -theories/Arith/max.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/max.cmi -theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/max.cmi -theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/min.cmi -theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/min.cmi theories/Arith/minus.cmo: theories/Arith/minus.cmi theories/Arith/minus.cmx: theories/Arith/minus.cmi -theories/Arith/mult.cmo: theories/Init/datatypes.cmi theories/Arith/plus.cmi \ +theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \ theories/Arith/mult.cmi -theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.cmx \ +theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \ theories/Arith/mult.cmi -theories/Arith/peano_dec.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/peano_dec.cmi -theories/Arith/peano_dec.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/peano_dec.cmi -theories/Arith/plus.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi +theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi +theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/plus.cmi -theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/plus.cmi theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \ theories/Arith/wf_nat.cmi theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \ theories/Arith/wf_nat.cmi -theories/Bool/boolEq.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/boolEq.cmi -theories/Bool/boolEq.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/boolEq.cmi -theories/Bool/bool.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Bool/boolEq.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/boolEq.cmi +theories/Bool/boolEq.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/boolEq.cmi +theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Bool/bool.cmi -theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Bool/bool.cmi -theories/Bool/bvector.cmo: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Bool/bvector.cmi -theories/Bool/bvector.cmx: theories/Bool/bool.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Bool/bvector.cmi +theories/Bool/bvector.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/Bool/bvector.cmi +theories/Bool/bvector.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ + theories/Bool/bvector.cmi theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi -theories/Bool/ifProp.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/ifProp.cmi -theories/Bool/ifProp.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/ifProp.cmi -theories/Bool/sumbool.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/Bool/sumbool.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmi +theories/Bool/ifProp.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/ifProp.cmi +theories/Bool/ifProp.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/ifProp.cmi +theories/Bool/sumbool.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/sumbool.cmi +theories/Bool/sumbool.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/sumbool.cmi theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi +theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ + theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi +theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \ + theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi +theories/FSets/decidableType.cmo: theories/Init/specif.cmi \ + theories/FSets/decidableType.cmi +theories/FSets/decidableType.cmx: theories/Init/specif.cmx \ + theories/FSets/decidableType.cmi +theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/int.cmi theories/FSets/fMapList.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi +theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/int.cmx theories/FSets/fMapList.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi +theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi +theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi +theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/FSets/fMapInterface.cmi +theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/FSets/fMapInterface.cmi +theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ + theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi +theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \ + theories/IntMap/map.cmx theories/Lists/list.cmx \ + theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi +theories/FSets/fMapList.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapList.cmi +theories/FSets/fMapList.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapList.cmi +theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/FSets/fMapPositive.cmi +theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/FSets/fMapPositive.cmi +theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi +theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi +theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi +theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi +theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ + theories/FSets/fMapWeakInterface.cmi +theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \ + theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ + theories/FSets/fMapWeakInterface.cmi +theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi +theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/decidableType.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi +theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi +theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi +theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/int.cmi \ + theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ + theories/FSets/fSetAVL.cmi +theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ + theories/Init/peano.cmx theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/FSets/int.cmx \ + theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ + theories/FSets/fSetAVL.cmi +theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetBridge.cmi +theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetBridge.cmi +theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Init/peano.cmi \ + theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi +theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/Init/peano.cmx \ + theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi +theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetFacts.cmi +theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetFacts.cmi +theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi +theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi +theories/FSets/fSetList.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetList.cmi +theories/FSets/fSetList.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetList.cmi +theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \ + theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetProperties.cmi +theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \ + theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetProperties.cmi +theories/FSets/fSets.cmo: theories/FSets/fSets.cmi +theories/FSets/fSets.cmx: theories/FSets/fSets.cmi +theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetToFiniteSet.cmi +theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetToFiniteSet.cmi +theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi +theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi +theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetWeakInterface.cmi +theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \ + theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetWeakInterface.cmi +theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi +theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/decidableType.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi +theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi +theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi +theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi +theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/Lists/list.cmx \ + theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi +theories/FSets/int.cmo: theories/ZArith/zmax.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ + theories/FSets/int.cmi +theories/FSets/int.cmx: theories/ZArith/zmax.cmx \ + theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ + theories/FSets/int.cmi +theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/FSets/orderedTypeAlt.cmi +theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ + theories/FSets/orderedTypeAlt.cmi +theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \ + theories/FSets/orderedTypeEx.cmi +theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ + theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \ + theories/FSets/orderedTypeEx.cmi +theories/FSets/orderedType.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/FSets/orderedType.cmi +theories/FSets/orderedType.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/FSets/orderedType.cmi theories/Init/datatypes.cmo: theories/Init/datatypes.cmi theories/Init/datatypes.cmx: theories/Init/datatypes.cmi theories/Init/logic.cmo: theories/Init/logic.cmi theories/Init/logic.cmx: theories/Init/logic.cmi -theories/Init/logic_Type.cmo: theories/Init/datatypes.cmi \ - theories/Init/logic_Type.cmi -theories/Init/logic_Type.cmx: theories/Init/datatypes.cmx \ - theories/Init/logic_Type.cmi +theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi +theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi theories/Init/notations.cmo: theories/Init/notations.cmi theories/Init/notations.cmx: theories/Init/notations.cmi theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi @@ -116,152 +324,146 @@ theories/Init/specif.cmo: theories/Init/datatypes.cmi \ theories/Init/specif.cmi theories/Init/specif.cmx: theories/Init/datatypes.cmx \ theories/Init/specif.cmi +theories/Init/tactics.cmo: theories/Init/tactics.cmi +theories/Init/tactics.cmx: theories/Init/tactics.cmi theories/Init/wf.cmo: theories/Init/wf.cmi theories/Init/wf.cmx: theories/Init/wf.cmi -theories/IntMap/adalloc.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/adalloc.cmi -theories/IntMap/adalloc.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/NArith/binPos.cmx \ - theories/Init/datatypes.cmx theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/adalloc.cmi -theories/IntMap/addec.cmo: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/addec.cmi -theories/IntMap/addec.cmx: theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/addec.cmi -theories/IntMap/addr.cmo: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/IntMap/addr.cmi -theories/IntMap/addr.cmx: theories/NArith/binPos.cmx theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/IntMap/addr.cmi -theories/IntMap/adist.cmo: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/IntMap/adist.cmi -theories/IntMap/adist.cmx: theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/IntMap/adist.cmi +theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi +theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi -theories/IntMap/fset.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/IntMap/fset.cmi -theories/IntMap/fset.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/Init/datatypes.cmx theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/IntMap/fset.cmi -theories/IntMap/lsort.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Lists/list.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/lsort.cmi -theories/IntMap/lsort.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/Lists/list.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/lsort.cmi +theories/IntMap/fset.cmo: theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/fset.cmi +theories/IntMap/fset.cmx: theories/Init/specif.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/map.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/fset.cmi +theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/lsort.cmi +theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/lsort.cmi theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi -theories/IntMap/mapcanon.cmo: theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/IntMap/mapcanon.cmi -theories/IntMap/mapcanon.cmx: theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/IntMap/mapcanon.cmi -theories/IntMap/mapcard.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/map.cmi theories/Init/peano.cmi \ - theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/mapcard.cmi -theories/IntMap/mapcard.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/IntMap/map.cmx theories/Init/peano.cmx \ - theories/Arith/peano_dec.cmx theories/Arith/plus.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/mapcard.cmi +theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi +theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \ + theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi +theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/plus.cmi \ + theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi +theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Arith/plus.cmx \ + theories/Arith/peano_dec.cmx theories/Init/peano.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/map.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi -theories/IntMap/mapfold.cmo: theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/IntMap/mapfold.cmi -theories/IntMap/mapfold.cmx: theories/IntMap/addr.cmx \ - theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ - theories/Init/specif.cmx theories/IntMap/mapfold.cmi -theories/IntMap/mapiter.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/IntMap/mapiter.cmi -theories/IntMap/mapiter.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/IntMap/map.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/IntMap/mapiter.cmi -theories/IntMap/maplists.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ - theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/IntMap/maplists.cmi -theories/IntMap/maplists.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/IntMap/fset.cmx theories/Lists/list.cmx theories/IntMap/map.cmx \ - theories/IntMap/mapiter.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/IntMap/maplists.cmi -theories/IntMap/map.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi theories/IntMap/map.cmi -theories/IntMap/map.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx theories/IntMap/map.cmi -theories/IntMap/mapsubset.cmo: theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ +theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/IntMap/fset.cmi theories/Init/datatypes.cmi \ + theories/IntMap/mapfold.cmi +theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/IntMap/fset.cmx theories/Init/datatypes.cmx \ + theories/IntMap/mapfold.cmi +theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndigits.cmi \ + theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi \ + theories/IntMap/mapiter.cmi +theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndigits.cmx \ + theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binNat.cmx \ + theories/IntMap/mapiter.cmi +theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/IntMap/maplists.cmi +theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndec.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/Lists/list.cmx theories/IntMap/fset.cmx \ + theories/Init/datatypes.cmx theories/IntMap/maplists.cmi +theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/IntMap/map.cmi +theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/IntMap/map.cmi +theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \ + theories/IntMap/map.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ theories/IntMap/mapsubset.cmi -theories/IntMap/mapsubset.cmx: theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ +theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \ + theories/IntMap/map.cmx theories/IntMap/fset.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ theories/IntMap/mapsubset.cmi -theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Lists/list.cmi -theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Lists/list.cmi -theories/Lists/listSet.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi \ - theories/Lists/listSet.cmi -theories/Lists/listSet.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx \ - theories/Lists/listSet.cmi +theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Lists/listSet.cmi +theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/Lists/listSet.cmi theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \ theories/Lists/monoList.cmi theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \ theories/Lists/monoList.cmi +theories/Lists/setoidList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/Lists/setoidList.cmi +theories/Lists/setoidList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/Lists/setoidList.cmi theories/Lists/streams.cmo: theories/Init/datatypes.cmi \ theories/Lists/streams.cmi theories/Lists/streams.cmx: theories/Init/datatypes.cmx \ theories/Lists/streams.cmi -theories/Lists/theoryList.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi \ +theories/Lists/theoryList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ theories/Lists/theoryList.cmi -theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx \ +theories/Lists/theoryList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ theories/Lists/theoryList.cmi theories/Logic/berardi.cmo: theories/Logic/berardi.cmi theories/Logic/berardi.cmx: theories/Logic/berardi.cmi -theories/Logic/choiceFacts.cmo: theories/Logic/choiceFacts.cmi -theories/Logic/choiceFacts.cmx: theories/Logic/choiceFacts.cmi +theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi +theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi -theories/Logic/classicalDescription.cmo: \ - theories/Logic/classicalDescription.cmi -theories/Logic/classicalDescription.cmx: \ - theories/Logic/classicalDescription.cmi +theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi +theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \ + theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi +theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi +theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \ + theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi theories/Logic/classical.cmo: theories/Logic/classical.cmi @@ -272,38 +474,118 @@ theories/Logic/classical_Pred_Type.cmo: \ theories/Logic/classical_Pred_Type.cmi theories/Logic/classical_Pred_Type.cmx: \ theories/Logic/classical_Pred_Type.cmi -theories/Logic/classical_Prop.cmo: theories/Logic/classical_Prop.cmi -theories/Logic/classical_Prop.cmx: theories/Logic/classical_Prop.cmi +theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/classical_Prop.cmi +theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/classical_Prop.cmi theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi +theories/Logic/classicalUniqueChoice.cmo: \ + theories/Logic/classicalUniqueChoice.cmi +theories/Logic/classicalUniqueChoice.cmx: \ + theories/Logic/classicalUniqueChoice.cmi theories/Logic/decidable.cmo: theories/Logic/decidable.cmi theories/Logic/decidable.cmx: theories/Logic/decidable.cmi -theories/Logic/diaconescu.cmo: theories/Logic/diaconescu.cmi -theories/Logic/diaconescu.cmx: theories/Logic/diaconescu.cmi -theories/Logic/eqdep_dec.cmo: theories/Logic/eqdep_dec.cmi -theories/Logic/eqdep_dec.cmx: theories/Logic/eqdep_dec.cmi -theories/Logic/eqdep.cmo: theories/Logic/eqdep.cmi -theories/Logic/eqdep.cmx: theories/Logic/eqdep.cmi +theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \ + theories/Logic/diaconescu.cmi +theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \ + theories/Logic/diaconescu.cmi +theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \ + theories/Logic/eqdep_dec.cmi +theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \ + theories/Logic/eqdep_dec.cmi +theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi +theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi +theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/eqdep.cmi +theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/eqdep.cmi theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi -theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevance.cmi -theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevance.cmi +theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/proofIrrelevanceFacts.cmi +theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/proofIrrelevanceFacts.cmi +theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \ + theories/Logic/proofIrrelevance.cmi +theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \ + theories/Logic/proofIrrelevance.cmi theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi -theories/NArith/binNat.cmo: theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/NArith/binNat.cmi -theories/NArith/binNat.cmx: theories/NArith/binPos.cmx \ - theories/Init/datatypes.cmx theories/NArith/binNat.cmi -theories/NArith/binPos.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/NArith/binPos.cmi -theories/NArith/binPos.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/NArith/binPos.cmi +theories/NArith/binNat.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/binNat.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmi +theories/NArith/binPos.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/NArith/binPos.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmi theories/NArith/nArith.cmo: theories/NArith/nArith.cmi theories/NArith/nArith.cmx: theories/NArith/nArith.cmi +theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ + theories/NArith/ndec.cmi +theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ + theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ + theories/NArith/ndec.cmi +theories/NArith/ndigits.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/Bool/bool.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/NArith/ndigits.cmi +theories/NArith/ndigits.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ + theories/Bool/bool.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/NArith/ndigits.cmi +theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/NArith/ndist.cmi +theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/NArith/ndist.cmi +theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ + theories/NArith/nnat.cmi +theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ + theories/NArith/nnat.cmi theories/NArith/pnat.cmo: theories/NArith/pnat.cmi theories/NArith/pnat.cmx: theories/NArith/pnat.cmi +theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/Setoids/setoid.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi +theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \ + theories/Init/specif.cmx theories/Setoids/setoid.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi +theories/QArith/qArith.cmo: theories/QArith/qArith.cmi +theories/QArith/qArith.cmx: theories/QArith/qArith.cmi +theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qreals.cmi +theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qreals.cmi +theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \ + theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi +theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \ + theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi +theories/QArith/qring.cmo: theories/Init/specif.cmi \ + theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \ + theories/QArith/qring.cmi +theories/QArith/qring.cmx: theories/Init/specif.cmx \ + theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \ + theories/QArith/qring.cmi theories/Relations/newman.cmo: theories/Relations/newman.cmi theories/Relations/newman.cmx: theories/Relations/newman.cmi theories/Relations/operators_Properties.cmo: \ @@ -314,16 +596,18 @@ theories/Relations/relation_Definitions.cmo: \ theories/Relations/relation_Definitions.cmi theories/Relations/relation_Definitions.cmx: \ theories/Relations/relation_Definitions.cmi -theories/Relations/relation_Operators.cmo: theories/Lists/list.cmi \ - theories/Init/specif.cmi theories/Relations/relation_Operators.cmi -theories/Relations/relation_Operators.cmx: theories/Lists/list.cmx \ - theories/Init/specif.cmx theories/Relations/relation_Operators.cmi +theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Relations/relation_Operators.cmi +theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Relations/relation_Operators.cmi theories/Relations/relations.cmo: theories/Relations/relations.cmi theories/Relations/relations.cmx: theories/Relations/relations.cmi theories/Relations/rstar.cmo: theories/Relations/rstar.cmi theories/Relations/rstar.cmx: theories/Relations/rstar.cmi -theories/Setoids/setoid.cmo: theories/Setoids/setoid.cmi -theories/Setoids/setoid.cmx: theories/Setoids/setoid.cmi +theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \ + theories/Setoids/setoid.cmi +theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \ + theories/Setoids/setoid.cmi theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi @@ -340,20 +624,18 @@ theories/Sets/image.cmo: theories/Sets/image.cmi theories/Sets/image.cmx: theories/Sets/image.cmi theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi -theories/Sets/integers.cmo: theories/Init/datatypes.cmi \ - theories/Sets/partial_Order.cmi theories/Sets/integers.cmi -theories/Sets/integers.cmx: theories/Init/datatypes.cmx \ - theories/Sets/partial_Order.cmx theories/Sets/integers.cmi -theories/Sets/multiset.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi \ - theories/Sets/multiset.cmi -theories/Sets/multiset.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx \ - theories/Sets/multiset.cmi -theories/Sets/partial_Order.cmo: theories/Sets/ensembles.cmi \ - theories/Sets/relations_1.cmi theories/Sets/partial_Order.cmi -theories/Sets/partial_Order.cmx: theories/Sets/ensembles.cmx \ - theories/Sets/relations_1.cmx theories/Sets/partial_Order.cmi +theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \ + theories/Init/datatypes.cmi theories/Sets/integers.cmi +theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \ + theories/Init/datatypes.cmx theories/Sets/integers.cmi +theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Sets/multiset.cmi +theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Sets/multiset.cmi +theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \ + theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi +theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \ + theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi theories/Sets/permut.cmo: theories/Sets/permut.cmi theories/Sets/permut.cmx: theories/Sets/permut.cmi theories/Sets/powerset_Classical_facts.cmo: \ @@ -362,10 +644,10 @@ theories/Sets/powerset_Classical_facts.cmx: \ theories/Sets/powerset_Classical_facts.cmi theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi -theories/Sets/powerset.cmo: theories/Sets/ensembles.cmi \ - theories/Sets/partial_Order.cmi theories/Sets/powerset.cmi -theories/Sets/powerset.cmx: theories/Sets/ensembles.cmx \ - theories/Sets/partial_Order.cmx theories/Sets/powerset.cmi +theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \ + theories/Sets/ensembles.cmi theories/Sets/powerset.cmi +theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \ + theories/Sets/ensembles.cmx theories/Sets/powerset.cmi theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi @@ -378,30 +660,46 @@ theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi -theories/Sets/uniset.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Sets/uniset.cmi -theories/Sets/uniset.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Sets/uniset.cmi -theories/Sorting/heap.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Sorting/sorting.cmi \ - theories/Init/specif.cmi theories/Sorting/heap.cmi -theories/Sorting/heap.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Sets/multiset.cmx \ - theories/Init/peano.cmx theories/Sorting/sorting.cmx \ - theories/Init/specif.cmx theories/Sorting/heap.cmi -theories/Sorting/permutation.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi \ +theories/Sets/uniset.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Sets/uniset.cmi +theories/Sets/uniset.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Sets/uniset.cmi +theories/Sorting/heap.cmo: theories/Init/specif.cmi \ + theories/Sorting/sorting.cmi theories/Init/peano.cmi \ + theories/Sets/multiset.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Sorting/heap.cmi +theories/Sorting/heap.cmx: theories/Init/specif.cmx \ + theories/Sorting/sorting.cmx theories/Init/peano.cmx \ + theories/Sets/multiset.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/Sorting/heap.cmi +theories/Sorting/permutation.cmo: theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/Sets/multiset.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ theories/Sorting/permutation.cmi -theories/Sorting/permutation.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Sets/multiset.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx \ +theories/Sorting/permutation.cmx: theories/Init/specif.cmx \ + theories/Init/peano.cmx theories/Sets/multiset.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ theories/Sorting/permutation.cmi -theories/Sorting/sorting.cmo: theories/Lists/list.cmi \ - theories/Init/specif.cmi theories/Sorting/sorting.cmi -theories/Sorting/sorting.cmx: theories/Lists/list.cmx \ - theories/Init/specif.cmx theories/Sorting/sorting.cmi +theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi +theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi +theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi +theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi +theories/Sorting/sorting.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Sorting/sorting.cmi +theories/Sorting/sorting.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Sorting/sorting.cmi +theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/NArith/binPos.cmi theories/Strings/ascii.cmi +theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ + theories/NArith/binPos.cmx theories/Strings/ascii.cmi +theories/Strings/string.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Strings/ascii.cmi \ + theories/Strings/string.cmi +theories/Strings/string.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Strings/ascii.cmx \ + theories/Strings/string.cmi theories/Wellfounded/disjoint_Union.cmo: \ theories/Wellfounded/disjoint_Union.cmi theories/Wellfounded/disjoint_Union.cmx: \ @@ -434,280 +732,405 @@ theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \ theories/Wellfounded/well_Ordering.cmi theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi -theories/ZArith/binInt.cmo: theories/NArith/binNat.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ +theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ theories/ZArith/binInt.cmi -theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ +theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ theories/ZArith/binInt.cmi -theories/ZArith/wf_Z.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi -theories/ZArith/wf_Z.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmi -theories/ZArith/zabs.cmo: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zabs.cmi -theories/ZArith/zabs.cmx: theories/ZArith/binInt.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zabs.cmi +theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi +theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi +theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \ + theories/ZArith/zabs.cmi +theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \ + theories/ZArith/zabs.cmi theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi -theories/ZArith/zArith_dec.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi -theories/ZArith/zArith_dec.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi -theories/ZArith/zbinary.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zeven.cmi \ +theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zbinary.cmi -theories/ZArith/zbinary.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Bool/bvector.cmx \ - theories/Init/datatypes.cmx theories/ZArith/zeven.cmx \ +theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \ + theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zbinary.cmi -theories/ZArith/zbool.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zeven.cmi theories/ZArith/zbool.cmi -theories/ZArith/zbool.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmx \ - theories/ZArith/zeven.cmx theories/ZArith/zbool.cmi +theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \ + theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi +theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \ + theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi -theories/ZArith/zcomplements.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zabs.cmi theories/ZArith/zcomplements.cmi -theories/ZArith/zcomplements.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ - theories/ZArith/zabs.cmx theories/ZArith/zcomplements.cmi -theories/ZArith/zdiv.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zbool.cmi theories/ZArith/zdiv.cmi -theories/ZArith/zdiv.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/zArith_dec.cmx \ - theories/ZArith/zbool.cmx theories/ZArith/zdiv.cmi -theories/ZArith/zeven.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zeven.cmi -theories/ZArith/zeven.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/zeven.cmi +theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi +theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \ + theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi +theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi +theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \ + theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi +theories/ZArith/zeven.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi +theories/ZArith/zeven.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi -theories/ZArith/zlogarithm.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/ZArith/zlogarithm.cmi -theories/ZArith/zlogarithm.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/ZArith/zlogarithm.cmi -theories/ZArith/zmin.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zmin.cmi -theories/ZArith/zmin.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/ZArith/zmin.cmi -theories/ZArith/zmisc.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ +theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi +theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi +theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi +theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi +theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi +theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi +theories/ZArith/zmin.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ + theories/ZArith/zmin.cmi +theories/ZArith/zmin.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ + theories/ZArith/zmin.cmi +theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zmisc.cmi -theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ +theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zmisc.cmi theories/ZArith/znat.cmo: theories/ZArith/znat.cmi theories/ZArith/znat.cmx: theories/ZArith/znat.cmi -theories/ZArith/znumtheory.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ - theories/ZArith/zorder.cmi theories/ZArith/znumtheory.cmi -theories/ZArith/znumtheory.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ - theories/ZArith/zArith_dec.cmx theories/ZArith/zdiv.cmx \ - theories/ZArith/zorder.cmx theories/ZArith/znumtheory.cmi -theories/ZArith/zorder.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \ + theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi +theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \ + theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \ + theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi +theories/ZArith/zorder.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zorder.cmi -theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/ZArith/zorder.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zorder.cmi -theories/ZArith/zpower.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/ZArith/zmisc.cmi theories/ZArith/zpower.cmi -theories/ZArith/zpower.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/ZArith/zmisc.cmx theories/ZArith/zpower.cmi -theories/ZArith/zsqrt.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/specif.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zsqrt.cmi -theories/ZArith/zsqrt.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/specif.cmx \ - theories/ZArith/zArith_dec.cmx theories/ZArith/zsqrt.cmi +theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi +theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi +theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi +theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \ + theories/Init/specif.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi -theories/Arith/bool_nat.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/Arith/compare_dec.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/compare.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/div2.cmi: theories/Init/datatypes.cmi theories/Init/peano.cmi \ - theories/Init/specif.cmi -theories/Arith/eqNat.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/euclid.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/even.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/factorial.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi -theories/Arith/max.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/min.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/mult.cmi: theories/Init/datatypes.cmi theories/Arith/plus.cmi -theories/Arith/peano_dec.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/plus.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/compare.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Arith/eqNat.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/factorial.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi +theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi -theories/Bool/boolEq.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Bool/bool.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Bool/bvector.cmi: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi +theories/Bool/boolEq.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Bool/bvector.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi theories/Bool/decBool.cmi: theories/Init/specif.cmi -theories/Bool/ifProp.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Bool/sumbool.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi +theories/Bool/ifProp.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Bool/sumbool.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/zerob.cmi: theories/Init/datatypes.cmi -theories/Init/logic_Type.cmi: theories/Init/datatypes.cmi +theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/decidableType.cmi: theories/Init/specif.cmi +theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/int.cmi theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \ + theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ + theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi +theories/FSets/fMapList.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi +theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/int.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Init/peano.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/Bool/bool.cmi +theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetList.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi +theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi +theories/FSets/int.cmi: theories/ZArith/zmax.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi +theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/ZArith/binInt.cmi +theories/FSets/orderedType.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Init/peano.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi: theories/Init/datatypes.cmi -theories/IntMap/adalloc.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/addec.cmi: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/addr.cmi: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/IntMap/adist.cmi: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/IntMap/fset.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi -theories/IntMap/lsort.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Lists/list.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/mapcanon.cmi: theories/IntMap/map.cmi \ - theories/Init/specif.cmi -theories/IntMap/mapcard.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/map.cmi theories/Init/peano.cmi \ - theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/mapfold.cmi: theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi -theories/IntMap/mapiter.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/IntMap/maplists.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ - theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/IntMap/map.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/IntMap/mapsubset.cmi: theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi -theories/Lists/list.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Lists/listSet.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi +theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/fset.cmi: theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \ + theories/IntMap/map.cmi +theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/plus.cmi \ + theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/IntMap/fset.cmi theories/Init/datatypes.cmi +theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndigits.cmi \ + theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi +theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi +theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \ + theories/IntMap/map.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi +theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Lists/monoList.cmi: theories/Init/datatypes.cmi +theories/Lists/setoidList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi theories/Lists/streams.cmi: theories/Init/datatypes.cmi -theories/Lists/theoryList.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi -theories/NArith/binNat.cmi: theories/NArith/binPos.cmi \ +theories/Lists/theoryList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \ theories/Init/datatypes.cmi -theories/NArith/binPos.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi -theories/Relations/relation_Operators.cmi: theories/Lists/list.cmi \ - theories/Init/specif.cmi +theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi +theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi +theories/Logic/diaconescu.cmi: theories/Init/specif.cmi +theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi +theories/NArith/binNat.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/NArith/binPos.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/NArith/ndigits.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/Bool/bool.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/Setoids/setoid.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \ + theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qring.cmi: theories/Init/specif.cmi \ + theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi +theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi +theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi -theories/Sets/integers.cmi: theories/Init/datatypes.cmi \ - theories/Sets/partial_Order.cmi -theories/Sets/multiset.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/Sets/partial_Order.cmi: theories/Sets/ensembles.cmi \ - theories/Sets/relations_1.cmi -theories/Sets/powerset.cmi: theories/Sets/ensembles.cmi \ - theories/Sets/partial_Order.cmi -theories/Sets/uniset.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Sorting/heap.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Sorting/sorting.cmi \ - theories/Init/specif.cmi -theories/Sorting/permutation.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/Sorting/sorting.cmi: theories/Lists/list.cmi \ - theories/Init/specif.cmi -theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi -theories/ZArith/binInt.cmi: theories/NArith/binNat.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/ZArith/wf_Z.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/ZArith/zabs.cmi: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/ZArith/zArith_dec.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/ZArith/zbinary.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zeven.cmi -theories/ZArith/zbool.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zeven.cmi -theories/ZArith/zcomplements.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zabs.cmi -theories/ZArith/zdiv.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zbool.cmi -theories/ZArith/zeven.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/ZArith/zlogarithm.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi -theories/ZArith/zmin.cmi: theories/ZArith/binInt.cmi \ +theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \ theories/Init/datatypes.cmi -theories/ZArith/zmisc.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/ZArith/znumtheory.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ - theories/ZArith/zorder.cmi -theories/ZArith/zorder.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/ZArith/zpower.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/ZArith/zmisc.cmi -theories/ZArith/zsqrt.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/specif.cmi \ - theories/ZArith/zArith_dec.cmi +theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \ + theories/Sets/ensembles.cmi +theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \ + theories/Sets/ensembles.cmi +theories/Sets/uniset.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Sorting/heap.cmi: theories/Init/specif.cmi \ + theories/Sorting/sorting.cmi theories/Init/peano.cmi \ + theories/Sets/multiset.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/Sorting/permutation.cmi: theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/Sets/multiset.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/Sorting/sorting.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi +theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/NArith/binPos.cmi +theories/Strings/string.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Strings/ascii.cmi +theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi +theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi +theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \ + theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zeven.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zmin.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi +theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \ + theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zorder.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi +theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile index c9bb5623..65a54090 100644 --- a/contrib/extraction/test/Makefile +++ b/contrib/extraction/test/Makefile @@ -10,7 +10,7 @@ AXIOMSVO:= \ theories/Reals/% \ theories/Num/% -DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS)) +DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*)) INCL:= $(patsubst %,-I %,$(DIRS)) @@ -34,7 +34,7 @@ all: v2ml ml $(MLI) $(CMO) ml: $(ML) -depend: $(ML) +depend: #$(ML) rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend tree: diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc index 0fb556aa..e7204838 100644 --- a/contrib/extraction/test/custom/Adalloc +++ b/contrib/extraction/test/custom/Adalloc @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort index 6a185683..22ab18e3 100644 --- a/contrib/extraction/test/custom/Lsort +++ b/contrib/extraction/test/custom/Lsort @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map index 3e464e39..f024dbd7 100644 --- a/contrib/extraction/test/custom/Map +++ b/contrib/extraction/test/custom/Map @@ -1,3 +1,3 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard index ca555aa3..5932cf7b 100644 --- a/contrib/extraction/test/custom/Mapcard +++ b/contrib/extraction/test/custom/Mapcard @@ -1,4 +1,4 @@ Require Import Plus. Extraction NoInline plus_is_one. -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter index 6a185683..22ab18e3 100644 --- a/contrib/extraction/test/custom/Mapiter +++ b/contrib/extraction/test/custom/Mapiter @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v deleted file mode 100644 index 0745f62d..00000000 --- a/contrib/extraction/test_extraction.v +++ /dev/null @@ -1,552 +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 Arith. -Require Import List. - -(*** STANDARD EXAMPLES *) - -(** Functions. *) - -Definition idnat (x:nat) := x. -Extraction idnat. -(* let idnat x = x *) - -Definition id (X:Type) (x:X) := x. -Extraction id. (* let id x = x *) -Definition id' := id Set nat. -Extraction id'. (* type id' = nat *) - -Definition test2 (f:nat -> nat) (x:nat) := f x. -Extraction test2. -(* let test2 f x = f x *) - -Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. -Extraction test3. -(* let test3 f x = f x __ *) - -Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. -Extraction test4. -(* let test4 f x g = f g *) - -Definition test5 := (1, 0). -Extraction test5. -(* let test5 = Pair ((S O), O) *) - -Definition cf (x:nat) (_:x <= 0) := S x. -Extraction NoInline cf. -Definition test6 := cf 0 (le_n 0). -Extraction test6. -(* let test6 = cf O *) - -Definition test7 := (fun (X:Set) (x:X) => x) nat. -Extraction test7. -(* let test7 x = x *) - -Definition d (X:Type) := X. -Extraction d. (* type 'x d = 'x *) -Definition d2 := d Set. -Extraction d2. (* type d2 = __ d *) -Definition d3 (x:d Set) := 0. -Extraction d3. (* let d3 _ = O *) -Definition d4 := d nat. -Extraction d4. (* type d4 = nat d *) -Definition d5 := (fun x:d Type => 0) Type. -Extraction d5. (* let d5 = O *) -Definition d6 (x:d Type) := x. -Extraction d6. (* type 'x d6 = 'x *) - -Definition test8 := (fun (X:Type) (x:X) => x) Set nat. -Extraction test8. (* type test8 = nat *) - -Definition test9 := let t := nat in id Set t. -Extraction test9. (* type test9 = nat *) - -Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. -Extraction test10. (* let test10 = O *) - -Definition test11 := let n := 0 in let p := S n in S p. -Extraction test11. (* let test11 = S (S O) *) - -Definition test12 := forall x:forall X:Type, X -> X, x Type Type. -Extraction test12. -(* type test12 = (__ -> __ -> __) -> __ *) - - -Definition test13 := match left True I with - | left x => 1 - | right x => 0 - end. -Extraction test13. (* let test13 = S O *) - - -(** example with more arguments that given by the type *) - -Definition test19 := - nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) - (fun (n:nat) (f:nat -> nat) => f) 0 0. -Extraction test19. -(* let test19 = - let rec f = function - | O -> (fun n0 -> O) - | S n0 -> f n0 - in f O O -*) - - -(** casts *) - -Definition test20 := True:Type. -Extraction test20. -(* type test20 = __ *) - - -(** Simple inductive type and recursor. *) - -Extraction nat. -(* -type nat = - | O - | S of nat -*) - -Extraction sumbool_rect. -(* -let sumbool_rect f f0 = function - | Left -> f __ - | Right -> f0 __ -*) - -(** Less simple inductive type. *) - -Inductive c (x:nat) : nat -> Set := - | refl : c x x - | trans : forall y z:nat, c x y -> y <= z -> c x z. -Extraction c. -(* -type c = - | Refl - | Trans of nat * nat * c -*) - -Definition Ensemble (U:Type) := U -> Prop. -Definition Empty_set (U:Type) (x:U) := False. -Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. - -Inductive Finite (U:Type) : Ensemble U -> Set := - | Empty_is_finite : Finite U (Empty_set U) - | Union_is_finite : - forall A:Ensemble U, - Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). -Extraction Finite. -(* -type 'u finite = - | Empty_is_finite - | Union_is_finite of 'u finite * 'u -*) - - -(** Mutual Inductive *) - -Inductive tree : Set := - Node : nat -> forest -> tree -with forest : Set := - | Leaf : nat -> forest - | Cons : tree -> forest -> forest. - -Extraction tree. -(* -type tree = - | Node of nat * forest -and forest = - | Leaf of nat - | Cons of tree * forest -*) - -Fixpoint tree_size (t:tree) : nat := - match t with - | Node a f => S (forest_size f) - end - - with forest_size (f:forest) : nat := - match f with - | Leaf b => 1 - | Cons t f' => tree_size t + forest_size f' - end. - -Extraction tree_size. -(* -let rec tree_size = function - | Node (a, f) -> S (forest_size f) -and forest_size = function - | Leaf b -> S O - | Cons (t, f') -> plus (tree_size t) (forest_size f') -*) - - -(** Eta-expansions of inductive constructor *) - -Inductive titi : Set := - tata : nat -> nat -> nat -> nat -> titi. -Definition test14 := tata 0. -Extraction test14. -(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) -Definition test15 := tata 0 1. -Extraction test15. -(* let test15 x x0 = Tata (O, (S O), x, x0) *) - -Inductive eta : Set := - eta_c : nat -> Prop -> nat -> Prop -> eta. -Extraction eta_c. -(* -type eta = - | Eta_c of nat * nat -*) -Definition test16 := eta_c 0. -Extraction test16. -(* let test16 x = Eta_c (O, x) *) -Definition test17 := eta_c 0 True. -Extraction test17. -(* let test17 x = Eta_c (O, x) *) -Definition test18 := eta_c 0 True 0. -Extraction test18. -(* let test18 _ = Eta_c (O, O) *) - - -(** Example of singleton inductive type *) - -Inductive bidon (A:Prop) (B:Type) : Set := - tb : forall (x:A) (y:B), bidon A B. -Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) - (x:A) (y:B) := f x y. -Extraction bidon. -(* type 'b bidon = 'b *) -Extraction tb. -(* tb : singleton inductive constructor *) -Extraction fbidon. -(* let fbidon f x y = - f x y -*) - -Definition fbidon2 := fbidon True nat (tb True nat). -Extraction fbidon2. (* let fbidon2 y = y *) -Extraction NoInline fbidon. -Extraction fbidon2. -(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) - -(* NB: first argument of fbidon2 has type [True], so it disappears. *) - -(** mutual inductive on many sorts *) - -Inductive test_0 : Prop := - ctest0 : test_0 -with test_1 : Set := - ctest1 : test_0 -> test_1. -Extraction test_0. -(* test0 : logical inductive *) -Extraction test_1. -(* -type test1 = - | Ctest1 -*) - -(** logical singleton *) - -Extraction eq. -(* eq : logical inductive *) -Extraction eq_rect. -(* let eq_rect x f y = - f -*) - -(** No more propagation of type parameters. Obj.t instead. *) - -Inductive tp1 : Set := - T : forall (C:Set) (c:C), tp2 -> tp1 -with tp2 : Set := - T' : tp1 -> tp2. -Extraction tp1. -(* -type tp1 = - | T of __ * tp2 -and tp2 = - | T' of tp1 -*) - -Inductive tp1bis : Set := - Tbis : tp2bis -> tp1bis -with tp2bis : Set := - T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. -Extraction tp1bis. -(* -type tp1bis = - | Tbis of tp2bis -and tp2bis = - | T'bis of __ * tp1bis -*) - - -(** Strange inductive type. *) - -Inductive Truc : Set -> Set := - | chose : forall A:Set, Truc A - | machin : forall A:Set, A -> Truc bool -> Truc A. -Extraction Truc. -(* -type 'x truc = - | Chose - | Machin of 'x * bool truc -*) - - -(** Dependant type over Type *) - -Definition test24 := sigT (fun a:Set => option a). -Extraction test24. -(* type test24 = (__, __ option) sigT *) - - -(** Coq term non strongly-normalizable after extraction *) - -Require Import Gt. -Definition loop (Ax:Acc gt 0) := - (fix F (a:nat) (b:Acc gt a) {struct b} : nat := - F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax. -Extraction loop. -(* let loop _ = - let rec f a = - f (S a) - in f O -*) - -(*** EXAMPLES NEEDING OBJ.MAGIC *) - -(** False conversion of type: *) - -Lemma oups : forall H:nat = list nat, nat -> nat. -intros. -generalize H0; intros. -rewrite H in H1. -case H1. -exact H0. -intros. -exact n. -Qed. -Extraction oups. -(* -let oups h0 = - match Obj.magic h0 with - | Nil -> h0 - | Cons0 (n, l) -> n -*) - - -(** hybrids *) - -Definition horibilis (b:bool) := - if b as b return (if b then Type else nat) then Set else 0. -Extraction horibilis. -(* -let horibilis = function - | True -> Obj.magic __ - | False -> Obj.magic O -*) - -Definition PropSet (b:bool) := if b then Prop else Set. -Extraction PropSet. (* type propSet = __ *) - -Definition natbool (b:bool) := if b then nat else bool. -Extraction natbool. (* type natbool = __ *) - -Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. -Extraction zerotrue. -(* -let zerotrue = function - | True -> Obj.magic O - | False -> Obj.magic True -*) - -Definition natProp (b:bool) := if b return Type then nat else Prop. - -Definition natTrue (b:bool) := if b return Type then nat else True. - -Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. -Extraction zeroTrue. -(* -let zeroTrue = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -Definition natTrue2 (b:bool) := if b return Type then nat else True. - -Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. -Extraction zeroprop. -(* -let zeroprop = function - | True -> Obj.magic O - | False -> Obj.magic __ -*) - -(** polymorphic f applied several times *) - -Definition test21 := (id nat 0, id bool true). -Extraction test21. -(* let test21 = Pair ((id O), (id True)) *) - -(** ok *) - -Definition test22 := - (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) - (fun (X:Type) (x:X) => x). -Extraction test22. -(* let test22 = - let f = fun x -> x in Pair ((f O), (f True)) *) - -(* still ok via optim beta -> let *) - -Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). -Extraction test23. -(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) - -(* problem: fun f -> (f 0, f true) not legal in ocaml *) -(* solution: magic ... *) - - -(** Dummy constant __ can be applied.... *) - -Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). -Extraction f. -(* let f x y = - y (x O) -*) - -Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). -Extraction NoInline f. -Extraction f_prop. -(* let f_prop = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). -Extraction f_arity. -(* let f_arity = - f (Obj.magic __) (fun _ -> True) -*) - -Definition f_normal := - f nat (fun x => x) (fun x => match x with - | O => true - | _ => false - end). -Extraction f_normal. -(* let f_normal = - f (fun x -> x) (fun x -> match x with - | O -> True - | S n -> False) -*) - - -(* inductive with magic needed *) - -Inductive Boite : Set := - boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. -Extraction Boite. -(* -type boite = - | Boite of bool * __ -*) - - -Definition boite1 := boite true 0. -Extraction boite1. -(* let boite1 = Boite (True, (Obj.magic O)) *) - -Definition boite2 := boite false (0, 0). -Extraction boite2. -(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) - -Definition test_boite (B:Boite) := - match B return nat with - | boite true n => n - | boite false n => fst n + snd n - end. -Extraction test_boite. -(* -let test_boite = function - | Boite (b0, n) -> - (match b0 with - | True -> Obj.magic n - | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) -*) - -(* singleton inductive with magic needed *) - -Inductive Box : Set := - box : forall A:Set, A -> Box. -Extraction Box. -(* type box = __ *) - -Definition box1 := box nat 0. -Extraction box1. (* let box1 = Obj.magic O *) - -(* applied constant, magic needed *) - -Definition idzarb (b:bool) (x:if b then nat else bool) := x. -Definition zarb := idzarb true 0. -Extraction NoInline idzarb. -Extraction zarb. -(* let zarb = Obj.magic idzarb True (Obj.magic O) *) - -(** function of variable arity. *) -(** Fun n = nat -> nat -> ... -> nat *) - -Fixpoint Fun (n:nat) : Set := - match n with - | O => nat - | S n => nat -> Fun n - end. - -Fixpoint Const (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => k - | S n => fun p:nat => Const k n - end. - -Fixpoint proj (k n:nat) {struct n} : Fun n := - match n as x return Fun x with - | O => 0 (* ou assert false ....*) - | S n => - match k with - | O => fun x => Const x n - | S k => fun x => proj k n - end - end. - -Definition test_proj := proj 2 4 0 1 2 3. - -Eval compute in test_proj. - -Recursive Extraction test_proj. - - - -(*** TO SUM UP: ***) - - -Extraction - "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2 - d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 - test13 test19 test20 nat sumbool_rect c Finite tree - tree_size test14 test15 eta_c test16 test17 test18 bidon - tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 - tp1bis Truc oups test24 loop horibilis PropSet natbool - zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop - f_arity f_normal Boite boite1 boite2 test_boite Box box1 - zarb test_proj. - diff --git a/contrib/field/LegacyField.v b/contrib/field/LegacyField.v new file mode 100644 index 00000000..08397d02 --- /dev/null +++ b/contrib/field/LegacyField.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* 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/Field_Compl.v b/contrib/field/LegacyField_Compl.v index cba921f7..b37281e9 100644 --- a/contrib/field/Field_Compl.v +++ b/contrib/field/LegacyField_Compl.v @@ -6,56 +6,33 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Compl.v,v 1.8.2.1 2004/07/16 19:30:09 herbelin Exp $ *) +(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *) -Inductive listT (A:Type) : Type := - | nilT : listT A - | consT : A -> listT A -> listT A. - -Fixpoint appT (A:Type) (l m:listT A) {struct l} : listT A := - match l with - | nilT => m - | consT a l1 => consT A a (appT A l1 m) - end. - -Inductive prodT (A B:Type) : Type := - pairT : A -> B -> prodT A B. +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:listT (prodT A B)) {struct lst} : + (lst:list (prod A B)) {struct lst} : B -> A -> A := fun (key:B) (default:A) => match lst with - | nilT => default - | consT (pairT v e) l => + | 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 fstT (A B:Type) (c:prodT A B) := match c with - | pairT a _ => a - end. - -Definition sndT (A B:Type) (c:prodT A B) := match c with - | pairT _ a => a - end. - Definition mem := (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) - (a:A) (l:listT A) {struct l} : bool := + (a:A) (l:list A) {struct l} : bool := match l with - | nilT => false - | consT a1 l1 => + | nil => false + | a1 :: l1 => match eq_dec a a1 with | left _ => true | right _ => mem A eq_dec a l1 end end). - -Inductive field_rel_option (A:Type) : Type := - | Field_None : field_rel_option A - | Field_Some : (A -> A -> A) -> field_rel_option A.
\ No newline at end of file diff --git a/contrib/field/Field_Tactic.v b/contrib/field/LegacyField_Tactic.v index c5c06547..2b6ff5b4 100644 --- a/contrib/field/Field_Tactic.v +++ b/contrib/field/LegacyField_Tactic.v @@ -6,72 +6,74 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Tactic.v,v 1.20.2.1 2004/07/16 19:30:09 herbelin Exp $ *) +(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *) -Require Import Ring. -Require Export Field_Compl. -Require Export Field_Theory. +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 - | (nilT _) => constr:false - | (consT _ ?X1 ?X2) => + | nil => constr:false + | ?X1 :: ?X2 => match constr:(X1 = var) with | (?X1 = ?X1) => constr:true | _ => mem_assoc var X2 end end. -Ltac seek_var_aux FT lvar trm := - let AT := eval cbv beta iota delta [A] in (A FT) - with AzeroT := eval cbv beta iota delta [Azero] in (Azero FT) - with AoneT := eval cbv beta iota delta [Aone] in (Aone FT) - with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) - with AmultT := eval cbv beta iota delta [Amult] in (Amult FT) - with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT) - with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in - match constr:trm with - | AzeroT => lvar - | AoneT => lvar - | (AplusT ?X1 ?X2) => - let l1 := seek_var_aux FT lvar X1 in - seek_var_aux FT l1 X2 - | (AmultT ?X1 ?X2) => - let l1 := seek_var_aux FT lvar X1 in - seek_var_aux FT l1 X2 - | (AoppT ?X1) => seek_var_aux FT lvar X1 - | (AinvT ?X1) => seek_var_aux FT lvar X1 - | ?X1 => - let res := mem_assoc X1 lvar in - match constr:res with - | true => lvar - | false => constr:(consT AT X1 lvar) - end - end. - -Ltac seek_var FT trm := - let AT := eval cbv beta iota delta [A] in (A FT) in - seek_var_aux FT (nilT AT) trm. - -Ltac number_aux lvar cpt := - match constr:lvar with - | (nilT ?X1) => constr:(nilT (prodT X1 nat)) - | (consT ?X1 ?X2 ?X3) => - let l2 := number_aux X3 (S cpt) in - constr:(consT (prodT X1 nat) (pairT X1 nat X2 cpt) l2) - end. - -Ltac number lvar := number_aux lvar 0. - -Ltac build_varlist FT trm := let lvar := seek_var FT trm in - number lvar. +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 - | (nilT _) => fail - | (consT (prodT _ nat) (pairT _ nat ?X1 ?X2) ?X3) => + | nil => fail + | (?X1,?X2) :: ?X3 => match constr:(elt = X1) with | (?X1 = ?X1) => constr:X2 | _ => assoc elt X3 @@ -79,13 +81,13 @@ Ltac assoc elt lst := end. Ltac interp_A FT lvar trm := - let AT := eval cbv beta iota delta [A] in (A FT) - with AzeroT := eval cbv beta iota delta [Azero] in (Azero FT) - with AoneT := eval cbv beta iota delta [Aone] in (Aone FT) - with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) - with AmultT := eval cbv beta iota delta [Amult] in (Amult FT) - with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT) - with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in + 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 @@ -112,32 +114,31 @@ Ltac interp_A FT lvar trm := Ltac remove e l := match constr:l with - | (nilT _) => l - | (consT ?X1 e ?X2) => constr:X2 - | (consT ?X1 ?X2 ?X3) => let nl := remove e X3 in - constr:(consT X1 X2 nl) + | 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 - | (nilT _) => l2 - | (consT ?X1 ?X2 ?X3) => + | nil => l2 + | ?X2 :: ?X3 => let nl2 := remove X2 l2 in let nl := union X3 nl2 in - constr:(consT X1 X2 nl) + constr:(X2 :: nl) end. Ltac raw_give_mult trm := match constr:trm with - | (EAinv ?X1) => constr:(consT ExprA X1 (nilT ExprA)) + | (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 (appT ExprA l1 l2) - | _ => constr:(nilT ExprA) + eval compute in (app l1 l2) + | _ => constr:(@nil ExprA) end. Ltac give_mult trm := @@ -181,18 +182,17 @@ Ltac weak_reduce := Ltac multiply mul := match goal with - | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA ?X1 ?X2 ?X4) => - let AzeroT := eval cbv beta iota delta [Azero X1] in (Azero X1) in - (cut (interp_ExprA X1 X2 mul <> AzeroT); - [ intro; let id := grep_mult in - apply (mult_eq X1 X3 X4 mul X2 id) - | weak_reduce; - let AoneT := eval cbv beta iota delta [Aone X1] in (Aone X1) - with AmultT := eval cbv beta iota delta [Amult X1] in (Amult X1) in - (try + | |- (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 X1) - end; clear X1 X2) ]) + | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT) + end; clear FT X2) ] end. Ltac apply_multiply FT lvar trm := @@ -219,10 +219,10 @@ Ltac apply_inverse mul FT lvar trm := Ltac strong_fail tac := first [ tac | fail 2 ]. Ltac inverse_test_aux FT trm := - let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) - with AmultT := eval cbv beta iota delta [Amult] in (Amult FT) - with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT) - with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in + 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) => @@ -235,7 +235,7 @@ Ltac inverse_test_aux FT trm := end. Ltac inverse_test FT := - let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) in + let AplusT := get_component Aplus FT in match goal with | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2) end. @@ -253,33 +253,33 @@ Ltac apply_simplif sfun := end. Ltac unfolds FT := - match eval cbv beta iota delta [Aminus] in (Aminus FT) with - | (Field_Some _ ?X1) => unfold X1 in |- * + match get_component Aminus FT with + | Some ?X1 => unfold X1 in |- * | _ => idtac end; - match eval cbv beta iota delta [Adiv] in (Adiv FT) with - | (Field_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 := eval cbv beta iota delta [Azero] in (Azero FT) - with AoneT := eval cbv beta iota delta [Aone] in (Aone FT) - with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) - with AmultT := eval cbv beta iota delta [Amult] in (Amult FT) - with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT) - with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in + 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 := eval cbv beta iota delta [Aplus] in (Aplus FT) in + 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 + cut (let ft := FT in let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); [ compute in |- *; auto @@ -287,13 +287,14 @@ Ltac field_gen_aux FT := 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; ring | field_gen_aux FT ] - | idtac ] ]) + (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; ring) || field_gen_aux FT. +Ltac field_gen FT := + unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT. (*****************************) (* Term Simplification *) @@ -303,12 +304,12 @@ Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT. Ltac init_exp FT trm := let e := - (match eval cbv beta iota delta [Aminus] in (Aminus FT) with - | (Field_Some _ ?X1) => eval cbv beta delta [X1] in trm + (match get_component Aminus FT with + | Some ?X1 => eval cbv beta delta [X1] in trm | _ => trm end) in - match eval cbv beta iota delta [Adiv] in (Adiv FT) with - | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e + match get_component Adiv FT with + | Some ?X1 => eval cbv beta delta [X1] in e | _ => e end. @@ -341,21 +342,21 @@ Ltac simpl_inv trm := Ltac map_tactic fcn lst := match constr:lst with - | (nilT _) => lst - | (consT ?X1 ?X2 ?X3) => + | nil => lst + | ?X2 :: ?X3 => let r := fcn X2 with t := map_tactic fcn X3 in - constr:(consT X1 r t) + constr:(r :: t) end. Ltac build_monom_aux lst trm := match constr:lst with - | (nilT _) => eval compute in (assoc trm) - | (consT _ ?X1 ?X2) => build_monom_aux X2 (EAmult trm X1) + | 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 (appT ExprA lnum ildn) 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 @@ -370,7 +371,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlnum := remove X1 lnum in simpl_monom_aux newlnum lden X2 - | false => simpl_monom_aux lnum (consT ExprA X1 lden) X2 + | false => simpl_monom_aux lnum (X1 :: lden) X2 end | (EAmult ?X1 ?X2) => let mma := mem_assoc X1 lden in @@ -378,7 +379,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlden := remove X1 lden in simpl_monom_aux lnum newlden X2 - | false => simpl_monom_aux (consT ExprA X1 lnum) lden X2 + | false => simpl_monom_aux (X1 :: lnum) lden X2 end | (EAinv ?X1) => let mma := mem_assoc X1 lnum in @@ -386,7 +387,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlnum := remove X1 lnum in build_monom newlnum lden - | false => build_monom lnum (consT ExprA X1 lden) + | false => build_monom lnum (X1 :: lden) end | ?X1 => let mma := mem_assoc X1 lden in @@ -394,11 +395,11 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlden := remove X1 lden in build_monom lnum newlden - | false => build_monom (consT ExprA X1 lnum) lden + | false => build_monom (X1 :: lnum) lden end end. -Ltac simpl_monom trm := simpl_monom_aux (nilT ExprA) (nilT ExprA) trm. +Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm. Ltac simpl_all_monomials trm := match constr:trm with @@ -429,4 +430,4 @@ Ltac field_term FT exp := 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; [ ring trep | field_gen FT ]).
\ No newline at end of file + (replace exp with trep; [ legacy ring trep | field_gen FT ]). diff --git a/contrib/field/Field_Theory.v b/contrib/field/LegacyField_Theory.v index 8737fd79..9c3a12fb 100644 --- a/contrib/field/Field_Theory.v +++ b/contrib/field/LegacyField_Theory.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Theory.v,v 1.12.2.1 2004/07/16 19:30:09 herbelin Exp $ *) +(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *) +Require Import List. Require Import Peano_dec. -Require Import Ring. -Require Import Field_Compl. +Require Import LegacyRing. +Require Import LegacyField_Compl. Record Field_Theory : Type := {A : Type; @@ -21,8 +22,8 @@ Record Field_Theory : Type := Aopp : A -> A; Aeq : A -> A -> bool; Ainv : A -> A; - Aminus : field_rel_option A; - Adiv : field_rel_option 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}. @@ -66,10 +67,10 @@ Definition eqExprA := Eval compute in eqExprA_O. (**** Generation of the multiplier ****) -Fixpoint mult_of_list (e:listT ExprA) : ExprA := +Fixpoint mult_of_list (e:list ExprA) : ExprA := match e with - | nilT => EAone - | consT e1 l1 => EAmult e1 (mult_of_list l1) + | nil => EAone + | e1 :: l1 => EAmult e1 (mult_of_list l1) end. Section Theory_of_fields. @@ -87,66 +88,66 @@ Let AinvT := Ainv T. Let RTT := RT T. Let Th_inv_defT := Th_inv_def T. -Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( +Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( Azero T) (Aopp T) (Aeq T) (RT T). -Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. +Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. (***************************) (* Lemmas to be used *) (***************************) -Lemma AplusT_sym : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. +Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_assoc : forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). Proof. - intros; ring. + intros; legacy ring. Qed. -Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. +Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AmultT_assoc : forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. Proof. - intros; ring. + 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; ring. + 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). - ring. + legacy ring. transitivity (AplusT (AplusT (AoppT r) r) r2). repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. - ring. + legacy ring. Qed. Lemma r_AmultT_mult : @@ -161,28 +162,28 @@ Qed. Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. Proof. - intros; rewrite AmultT_sym; apply Th_inv_defT; auto. + 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; ring. + intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring. Qed. (************************) @@ -191,7 +192,7 @@ Qed. (**** ExprA --> A ****) -Fixpoint interp_ExprA (lvar:listT (prodT AT nat)) (e:ExprA) {struct e} : +Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} : AT := match e with | EAzero => AzeroT @@ -257,7 +258,7 @@ Fixpoint assoc (e:ExprA) : ExprA := end. Lemma merge_mult_correct1 : - forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)), + 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. @@ -271,11 +272,11 @@ unfold merge_mult at 1 in |- *; fold merge_mult in |- *; Qed. Lemma merge_mult_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + 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 |- *; ring). +elim e0; try (intros; simpl in |- *; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AmultT (interp_ExprA lvar e2) @@ -285,12 +286,12 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2; (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 |- *; ring. -ring. + simpl in |- *; legacy ring. +legacy ring. Qed. Lemma assoc_mult_correct1 : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + 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)). @@ -302,12 +303,12 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; Qed. Lemma assoc_mult_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + 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 |- *; ring. +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. @@ -316,16 +317,16 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *; 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_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1)); + rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; - ring. + 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:listT (prodT AT nat)), + 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. @@ -339,11 +340,11 @@ unfold merge_plus at 1 in |- *; fold merge_plus in |- *; Qed. Lemma merge_plus_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + 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 |- *; ring). +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) @@ -353,12 +354,12 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2; (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 |- *; ring. -ring. + simpl in |- *; legacy ring. +legacy ring. Qed. Lemma assoc_plus_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + 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. @@ -369,7 +370,7 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; Qed. Lemma assoc_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (assoc e) = interp_ExprA lvar e. Proof. simple induction e; auto; intros. @@ -386,7 +387,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite - (AplusT_sym (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) + (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; rewrite (H0 lvar); rewrite <- @@ -396,10 +397,10 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; rewrite (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) (interp_ExprA lvar e3)); - rewrite (AplusT_sym (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_sym. + (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. @@ -448,39 +449,39 @@ Fixpoint distrib_main (e:ExprA) : ExprA := Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). Lemma distrib_mult_right_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + 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_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); - rewrite (H0 e2 lvar); ring. +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:listT (prodT AT nat)), + 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_sym. -rewrite AmultT_sym; +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_sym (interp_ExprA lvar e2) (interp_ExprA lvar e)); - rewrite (AmultT_sym (interp_ExprA lvar e2) (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_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +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:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. @@ -490,13 +491,13 @@ 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 |- *; ring. + simpl in |- *; fold AoppT in |- *; legacy ring. Qed. (**** Multiplication by the inverse product ****) Lemma mult_eq : - forall (e1 e2 a:ExprA) (lvar:listT (prodT AT nat)), + 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. @@ -520,17 +521,17 @@ Definition multiply (e:ExprA) : ExprA := end. Lemma multiply_aux_correct : - forall (a e:ExprA) (lvar:listT (prodT AT nat)), + 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); ring. + simpl in |- *; rewrite (H0 lvar); legacy ring. Qed. Lemma multiply_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply e) = interp_ExprA lvar e. Proof. simple induction e; simpl in |- *; auto. @@ -578,7 +579,7 @@ Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := end. Lemma monom_remove_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + 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). @@ -594,8 +595,8 @@ 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; [ ring | assumption ]. -simpl in |- *; rewrite H0; auto; ring. + (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. @@ -608,7 +609,7 @@ unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; Qed. Lemma monom_simplif_rem_correct : - forall (a e:ExprA) (lvar:listT (prodT AT nat)), + 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). @@ -618,11 +619,11 @@ simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; 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. -ring. +legacy ring. Qed. Lemma monom_simplif_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + 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. @@ -633,7 +634,7 @@ simpl in |- *; trivial. Qed. Lemma inverse_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + 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. @@ -642,4 +643,8 @@ 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.
\ No newline at end of file +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 index 32adec66..dab5a45c 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: field.ml4,v 1.33.2.1 2004/07/16 19:30:09 herbelin Exp $ *) +(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *) open Names open Pp @@ -21,19 +21,23 @@ 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 = Coqlib.gen_constant "Field" ("field"::dir) s +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 ((constant ["Field_Compl"] "Field_None"),[|ac|]) - | Some f -> mkApp ((constant ["Field_Compl"] "Field_Some"),[|ac;constr_of f|]) + | 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) @@ -43,7 +47,7 @@ let lookup env typ = with Not_found -> errorlabstrm "field" (str "No field is declared for type" ++ spc() ++ - Printer.prterm_env env typ) + Printer.pr_lconstr_env env typ) let _ = let init () = th_tab := Gmap.empty in @@ -82,7 +86,7 @@ let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth 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 ["Field_Theory"] "Build_Field_Theory"), + 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 (); @@ -113,8 +117,8 @@ END *) (* For the translator, otherwise the code above is OK *) -open Ppconstrnew -let pp_minus_div_arg _prc _prt (omin,odiv) = +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 ++ @@ -135,7 +139,7 @@ ARGUMENT EXTEND minus_div_arg END VERNAC COMMAND EXTEND Field - [ "Add" "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) ] @@ -149,8 +153,7 @@ END (* Guesses the type and calls field_gen with the right theory *) let field g = - Library.check_required_library ["Coq";"field";"Field"]; - let ist = { lfun=[]; debug=get_debug () } in + 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 @@ -172,7 +175,7 @@ let guess_theory env evc = function (* Guesses the type and calls Field_Term with the right theory *) let field_term l g = - Library.check_required_library ["Coq";"field";"Field"]; + 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)) @@ -184,7 +187,7 @@ let field_term l g = (* Declaration of Field *) -TACTIC EXTEND Field -| [ "Field" ] -> [ field ] -| [ "Field" ne_constr_list(l) ] -> [ field_term l ] +TACTIC EXTEND legacy_field +| [ "legacy" "field" ] -> [ field ] +| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ] END diff --git a/contrib/first-order/formula.ml b/contrib/first-order/formula.ml index 49cb8e25..0be468aa 100644 --- a/contrib/first-order/formula.ml +++ b/contrib/first-order/formula.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.ml,v 1.18.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *) open Hipattern open Names @@ -46,15 +46,14 @@ let rec nb_prod_after n c= | _ -> 0 let construct_nhyps ind gls = - let env=pf_env gls in - let nparams = (snd (Global.lookup_inductive ind)).mind_nparams in - let constr_types = Inductive.arities_of_constructors (pf_env gls) ind in + 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= Inductive.arities_of_constructors (pf_env gls) ind in + 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 @@ -99,7 +98,7 @@ let rec kind_of_formula gl term = let has_realargs=(n>0) in let is_trivial= let is_constant c = - nb_prod c = mip.mind_nparams in + 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) diff --git a/contrib/first-order/formula.mli b/contrib/first-order/formula.mli index db24f20f..8703045c 100644 --- a/contrib/first-order/formula.mli +++ b/contrib/first-order/formula.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.mli,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: formula.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term open Names diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4 index f85f2171..366f563b 100644 --- a/contrib/first-order/g_ground.ml4 +++ b/contrib/first-order/g_ground.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ground.ml4,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *) open Formula open Sequent @@ -24,7 +24,7 @@ open Libnames (* declaring search depth as a global option *) -let ground_depth=ref 5 +let ground_depth=ref 3 let _= let gdopt= @@ -34,14 +34,29 @@ let _= optread=(fun ()->Some !ground_depth); optwrite= (function - None->ground_depth:=5 + 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 "GTauto failed" + +let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") type external_env= Ids of global_reference list @@ -81,23 +96,32 @@ let normalize_evaluables= unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) -TACTIC EXTEND Firstorder - [ "Firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> - [ gen_ground_tac true (option_app eval_tactic t) (Ids l) ] -| [ "Firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> - [ gen_ground_tac true (option_app eval_tactic t) (Bases l) ] -| [ "Firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (option_app eval_tactic t) Void ] +TACTIC EXTEND firstorder + [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> + [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ] +| [ "firstorder" tactic_opt(t) "using" 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 -(* Obsolete since V8.0 -TACTIC EXTEND GTauto - [ "GTauto" ] -> - [ gen_ground_tac false (Some fail_solver) Void ] +TACTIC EXTEND gintuition + [ "gintuition" tactic_opt(t) ] -> + [ gen_ground_tac false (option_map eval_tactic t) Void ] END -*) -TACTIC EXTEND GIntuition - [ "GIntuition" tactic_opt(t) ] -> - [ gen_ground_tac false (option_app eval_tactic t) Void ] -END + +let default_declarative_automation gls = + tclORELSE + (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/first-order/ground.ml b/contrib/first-order/ground.ml index 23e27a3c..bccac6df 100644 --- a/contrib/first-order/ground.ml +++ b/contrib/first-order/ground.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.ml,v 1.5.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *) open Formula open Sequent @@ -45,23 +45,23 @@ let update_flags ()= *) let update_flags ()= - let predref=ref Names.KNpred.empty in + let predref=ref Names.Cpred.empty in let f coe= try let kn=destConst (Classops.get_coercion_value coe) in - predref:=Names.KNpred.add kn !predref + 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.KNpred.complement !predref) + (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 (Proof_trees.pr_goal (sig_it gl)); + then Pp.msgnl (Printer.pr_goal (sig_it gl)); tclORELSE (axiom_tac seq.gl seq) begin try @@ -78,10 +78,10 @@ let ground_tac solver startseq gl= | Rforall-> let backtrack1= if !qflag then - tclFAIL 0 "reversible in 1st order mode" + tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in - forall_tac backtrack continue (re_add seq1) + forall_tac backtrack1 continue (re_add seq1) | Rarrow-> arrow_tac backtrack continue (re_add seq1) | Ror-> @@ -117,7 +117,8 @@ let ground_tac solver startseq gl= backtrack2 (* need special backtracking *) | Lexists ind -> if !qflag then - left_exists_tac ind hd.id continue (re_add seq1) + left_exists_tac ind backtrack hd.id + continue (re_add seq1) else backtrack | LA (typ,lap)-> let la_tac= diff --git a/contrib/first-order/ground.mli b/contrib/first-order/ground.mli index cfc17e77..621f99db 100644 --- a/contrib/first-order/ground.mli +++ b/contrib/first-order/ground.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.mli,v 1.1.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $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/first-order/instances.ml b/contrib/first-order/instances.ml index e2e9e2ef..254d7b84 100644 --- a/contrib/first-order/instances.ml +++ b/contrib/first-order/instances.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: instances.ml,v 1.9.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) +(*i $Id: instances.ml 8654 2006-03-22 15:36:58Z msozeau $ i*) open Formula open Sequent @@ -105,10 +105,10 @@ let dummy_bvid=id_of_string "x" let mk_open_instance id gl m t= let env=pf_env gl in - let evmap=Refiner.sig_sig 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_reference id) in + 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 @@ -121,15 +121,18 @@ let mk_open_instance id gl m t= 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,env) [] [] nt 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,_,t0)-> let t1=raux (n-1) t0 in - RLambda(loc,name,RHole (dummy_loc,BinderType name),t1) + RLambda(loc,name,RHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in - let ntt=Pretyping.understand evmap env (raux m rawt) 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 *) @@ -138,13 +141,13 @@ let left_instance_tac (inst,id) continue seq= match inst with Phantom dom-> if lookup (id,None) seq then - tclFAIL 0 "already done" + tclFAIL 0 (Pp.str "already done") else tclTHENS (cut dom) [tclTHENLIST [introf; (fun gls->generalize - [mkApp(constr_of_reference id, + [mkApp(constr_of_global id, [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); introf; tclSOLVE [wrap 1 false continue @@ -152,7 +155,7 @@ let left_instance_tac (inst,id) continue seq= tclTRY assumption] | Real((m,t) as c,_)-> if lookup (id,Some c) seq then - tclFAIL 0 "already done" + tclFAIL 0 (Pp.str "already done") else let special_generalize= if m>0 then @@ -160,10 +163,10 @@ let left_instance_tac (inst,id) continue seq= let (rc,ot)= mk_open_instance id gl m t in let gt= it_mkLambda_or_LetIn - (mkApp(constr_of_reference id,[|ot|])) rc in + (mkApp(constr_of_global id,[|ot|])) rc in generalize [gt] gl else - generalize [mkApp(constr_of_reference id,[|t|])] + generalize [mkApp(constr_of_global id,[|t|])] in tclTHENLIST [special_generalize; @@ -186,7 +189,7 @@ let right_instance_tac inst continue seq= (tclTHEN (split (Rawterm.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> - tclFAIL 0 "not implemented ... yet" + tclFAIL 0 (Pp.str "not implemented ... yet") let instance_tac inst= if (snd inst)==dummy_id then diff --git a/contrib/first-order/instances.mli b/contrib/first-order/instances.mli index 509bfc70..7667c89f 100644 --- a/contrib/first-order/instances.mli +++ b/contrib/first-order/instances.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: instances.mli,v 1.3.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) +(*i $Id: instances.mli 5920 2004-07-16 20:01:26Z herbelin $ i*) open Term open Tacmach diff --git a/contrib/first-order/rules.ml b/contrib/first-order/rules.ml index 7fbefa37..6c51eda3 100644 --- a/contrib/first-order/rules.ml +++ b/contrib/first-order/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml,v 1.24.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *) open Util open Names @@ -57,18 +57,18 @@ let clear_global=function (* connection rules *) let axiom_tac t seq= - try exact_no_check (constr_of_reference (find_left t seq)) - with Not_found->tclFAIL 0 "No axiom link" + 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_reference id, - [|constr_of_reference (find_left a seq)|])]; + [generalize [mkApp(constr_of_global id, + [|constr_of_global (find_left a seq)|])]; clear_global id; intro] - with Not_found->tclFAIL 0 "No link") + with Not_found->tclFAIL 0 (Pp.str "No link")) (wrap 1 false continue seq) backtrack (* right connectives rules *) @@ -92,7 +92,7 @@ let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST - [simplest_elim (constr_of_reference id); + [simplest_elim (constr_of_global id); clear_global id; tclDO n intro]) (wrap n false continue seq) @@ -106,12 +106,12 @@ let left_or_tac ind backtrack id continue seq gls= tclDO n intro; wrap n false continue seq] in tclIFTHENSVELSE - (simplest_elim (constr_of_reference id)) + (simplest_elim (constr_of_global id)) (Array.map f v) backtrack gls let left_false_tac id= - simplest_elim (constr_of_reference id) + simplest_elim (constr_of_global id) (* left arrow connective rules *) @@ -127,7 +127,7 @@ let ll_ind_tac ind largs backtrack id continue seq gl= 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_reference id)),[|capply|]) 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 @@ -141,7 +141,7 @@ let ll_ind_tac ind largs backtrack id continue seq 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_reference id), + mkApp ((constr_of_global id), [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (cut c) @@ -150,7 +150,7 @@ let ll_arrow_tac a b c backtrack id continue seq= clear_global id; wrap 1 false continue seq]; tclTHENS (cut cc) - [exact_no_check (constr_of_reference id); + [exact_no_check (constr_of_global id); tclTHENLIST [generalize [d]; clear_global id; @@ -168,17 +168,19 @@ let forall_tac backtrack continue seq= (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) (if !qflag then - tclFAIL 0 "reversible in 1st order mode" + tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) -let left_exists_tac ind id continue seq gls= +let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in - tclTHENLIST - [simplest_elim (constr_of_reference id); - clear_global id; - tclDO n intro; - (wrap (n-1) false continue seq)] gls + 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 @@ -187,7 +189,7 @@ let ll_forall_tac prod backtrack id continue seq= [intro; (fun gls-> let id0=pf_nth_hyp_id gls 1 in - let term=mkApp((constr_of_reference id),[|mkVar(id0)|]) in + let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in tclTHEN (generalize [term]) (clear [id0]) gls); clear_global id; intro; @@ -209,6 +211,6 @@ let normalize_evaluables= onAllClauses (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some (id,_,_)-> + | Some ((_,id),_)-> unfold_in_hyp (Lazy.force defined_connectives) - (id,[],(Tacexpr.InHypTypeOnly,ref None))) + (([],id),Tacexpr.InHypTypeOnly)) diff --git a/contrib/first-order/rules.mli b/contrib/first-order/rules.mli index eb4d81bd..3798d8d4 100644 --- a/contrib/first-order/rules.mli +++ b/contrib/first-order/rules.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.mli,v 1.11.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: rules.mli 6141 2004-09-27 14:55:34Z corbinea $ *) open Term open Tacmach @@ -47,7 +47,7 @@ val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking val forall_tac : seqtac with_backtracking -val left_exists_tac : inductive -> lseqtac +val left_exists_tac : inductive -> lseqtac with_backtracking val ll_forall_tac : types -> lseqtac with_backtracking diff --git a/contrib/first-order/sequent.ml b/contrib/first-order/sequent.ml index 13215348..805700b0 100644 --- a/contrib/first-order/sequent.ml +++ b/contrib/first-order/sequent.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sequent.ml,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: sequent.ml 7925 2006-01-24 23:20:39Z herbelin $ *) open Term open Util @@ -91,8 +91,8 @@ let compare_constr_int f t1 t2 = | 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 + | 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 @@ -255,7 +255,7 @@ let empty_seq depth= let create_with_ref_list l depth gl= let f gr seq= - let c=constr_of_reference gr in + 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) @@ -269,7 +269,7 @@ let create_with_auto_hints l depth gl= Res_pf (c,_) | Give_exact c | Res_pf_THEN_trivial_fail (c,_) -> (try - let gr=reference_of_constr c in + 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->()) @@ -278,7 +278,7 @@ let create_with_auto_hints l depth gl= let h dbname= let hdb= try - Util.Stringmap.find dbname !searchtable + searchtable_map dbname with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in @@ -289,9 +289,9 @@ let print_cmap map= let print_entry c l s= let xc=Constrextern.extern_constr false (Global.env ()) c in str "| " ++ - Util.prlist (Ppconstr.pr_global Idset.empty) l ++ + Util.prlist Printer.pr_global l ++ str " : " ++ - Ppconstr.pr_constr xc ++ + Ppconstr.pr_constr_expr xc ++ cut () ++ s in msgnl (v 0 diff --git a/contrib/first-order/sequent.mli b/contrib/first-order/sequent.mli index df27d2ff..47fb74c7 100644 --- a/contrib/first-order/sequent.mli +++ b/contrib/first-order/sequent.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sequent.mli,v 1.8.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: sequent.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term open Util diff --git a/contrib/first-order/unify.ml b/contrib/first-order/unify.ml index 1186fb90..1dd13cbe 100644 --- a/contrib/first-order/unify.ml +++ b/contrib/first-order/unify.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: unify.ml,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) +(*i $Id: unify.ml 7639 2005-12-02 10:01:15Z gregoire $ i*) open Util open Formula @@ -59,8 +59,8 @@ let unif t1 t2= 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 + | 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)-> diff --git a/contrib/first-order/unify.mli b/contrib/first-order/unify.mli index dd9dbdec..9fbe3dda 100644 --- a/contrib/first-order/unify.mli +++ b/contrib/first-order/unify.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: unify.mli,v 1.7.2.1 2004/07/16 19:30:10 herbelin Exp $ *) +(* $Id: unify.mli 5920 2004-07-16 20:01:26Z herbelin $ *) open Term diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v index f6faf94c..1a1a5055 100644 --- a/contrib/fourier/Fourier.v +++ b/contrib/fourier/Fourier.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *) +(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) @@ -17,7 +17,7 @@ Declare ML Module "fourierR". Declare ML Module "field". Require Export Fourier_util. -Require Export Field. +Require Export LegacyField. Require Export DiscrR. Ltac fourier := abstract (fourierz; field; discrR). diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v index abcd4449..c3257b7d 100644 --- a/contrib/fourier/Fourier_util.v +++ b/contrib/fourier/Fourier_util.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier_util.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *) +(* $Id: Fourier_util.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Rbase. Comments "Lemmas used by the tactic Fourier". diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml index f5763c34..ed804e94 100644 --- a/contrib/fourier/fourier.ml +++ b/contrib/fourier/fourier.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourier.ml,v 1.2.16.1 2004/07/16 19:30:11 herbelin Exp $ *) +(* $Id: fourier.ml 5920 2004-07-16 20:01:26Z herbelin $ *) (* Méthode d'élimination de Fourier *) (* Référence: diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml index 49fa35da..f9518bcb 100644 --- a/contrib/fourier/fourierR.ml +++ b/contrib/fourier/fourierR.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourierR.ml,v 1.14.2.2 2004/07/19 13:28:28 herbelin Exp $ *) +(* $Id: fourierR.ml 7760 2005-12-30 10:49:13Z herbelin $ *) @@ -76,7 +76,7 @@ open Vernacexpr type ineq = Rlt | Rle | Rgt | Rge let string_of_R_constant kn = - match Names.repr_kn kn with + match Names.repr_con kn with | MPfile dir, sec_dir, id when sec_dir = empty_dirpath && string_of_dirpath dir = "Coq.Reals.Rdefinitions" @@ -85,13 +85,13 @@ let string_of_R_constant kn = let rec string_of_R_constr c = match kind_of_term c with - Cast (c,t) -> string_of_R_constr c + 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,t) -> (rational_of_constr c) + | Cast (c,_,_) -> (rational_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with | "Ropp" -> @@ -122,7 +122,7 @@ let rec rational_of_constr c = let rec flin_of_constr c = try( match kind_of_term c with - | Cast (c,t) -> (flin_of_constr c) + | Cast (c,_,_) -> (flin_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with "Ropp" -> @@ -221,7 +221,7 @@ let ineq1_of_constr (h,t) = hstrict=false}] |_->assert false) | Ind (kn,i) -> - if IndRef(kn,i) = Coqlib.glob_eqT then + if IndRef(kn,i) = Coqlib.glob_eq then let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in @@ -281,7 +281,7 @@ let constant = Coqlib.gen_constant "Fourier" (* Standard library *) open Coqlib -let coq_sym_eqT = lazy (build_coq_sym_eqT ()) +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 ()) @@ -303,7 +303,7 @@ let coq_R0 = lazy (constant_real "R0") let coq_R1 = lazy (constant_real "R1") (* RIneq *) -let coq_Rinv_R1 = lazy (constant ["Reals";"RIneq"] "Rinv_R1") +let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") (* Fourier_util *) let constant_fourier = constant ["fourier";"Fourier_util"] @@ -408,7 +408,7 @@ let tac_zero_infeq_false gl (n,d) = (tac_zero_inf_pos gl (-n,d))) ;; -let create_meta () = mkMeta(new_meta());; +let create_meta () = mkMeta(Evarutil.new_meta());; let my_cut c gl= let concl = pf_concl gl in @@ -458,7 +458,7 @@ let mkAppL a = (* Résolution d'inéquations linéaires dans R *) let rec fourier gl= - Library.check_required_library ["Coq";"fourier";"Fourier"]; + 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, @@ -604,7 +604,7 @@ let rec fourier gl= (Ring.polynom []) tclIDTAC; (tclTHEN (apply (get coq_sym_eqT)) - (apply (get coq_Rinv_R1)))] + (apply (get coq_Rinv_1)))] ) ])); diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4 index 05c3adbd..3a6be850 100644 --- a/contrib/fourier/g_fourier.ml4 +++ b/contrib/fourier/g_fourier.ml4 @@ -8,10 +8,10 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_fourier.ml4,v 1.1.12.1 2004/07/16 19:30:11 herbelin Exp $ *) +(* $Id: g_fourier.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) open FourierR -TACTIC EXTEND Fourier - [ "FourierZ" (* constr_list(l) *) ] -> [ fourier (* l *) ] +TACTIC EXTEND fourier + [ "fourierz" ] -> [ fourier ] END diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml new file mode 100644 index 00000000..ff4f7499 --- /dev/null +++ b/contrib/funind/functional_principles_proofs.ml @@ -0,0 +1,1551 @@ +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 !Options.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 (forward (Some (tclCOMPLETE tac)) (Genarg.IntroIdentifier prov_id) t)) + [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 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_as true (Genarg.IntroIdentifier 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[ + forward None (Genarg.IntroIdentifier 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(_,_,t,_) -> + 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 [[-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 + | 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 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); *) + (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 (out_some 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(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 (out_some finfos.equation_lemma) + with (Not_found | Failure "out_some" 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 + | Failure "out_some" -> + 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 + (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 ( + 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 + ( + (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 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 + (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 + (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 [([],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 + tclTHENSEQ + [ + generalize [lemma]; + h_intro hid; + Elim.h_decompose_and (mkVar hid); + tclTRY(list_rewrite true eqs); + Eauto.gen_eauto false (false,5) [] (Some []) + ] + gls + + +let backtrack_eqs_until_hrec hrec eqs : tactic = + fun gls -> + 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 new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic = + match !tcc_lemma_constr with + | None -> tclIDTAC_MESSAGE (str "No tcc proof !!") + | Some lemma -> + fun gls -> + let hid = next_global_ident_away true Recdef.h_id (pf_ids_of_hyps gls) in + (tclTHENSEQ + [ + generalize [lemma]; + h_intro hid; + Elim.h_decompose_and (mkVar hid); + 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 + [ + thin [hrec]; + apply (Lazy.force acc_inv); + (fun g -> + if is_mes + then + unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g + else tclIDTAC g + ); + observe_tac "rew_and_finish" + (tclTHEN + (tclTRY(Recdef.list_rewrite true eqs)) + (observe_tac "finishing" (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some []))))) + ] + ]) + ]) + 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 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 + (forward + (Some ((fun g -> observe_tac "prove wf" (tclCOMPLETE (wf_tac is_mes)) g))) + (Genarg.IntroIdentifier wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|]))) + ( + observe_tac + "apply wf_thm" + (h_apply ((mkApp(mkVar wf_thm_id, + [|mkVar rec_arg_id |])),Rawterm.NoBindings) + ) + ) + ) + ) + ) + g + in + let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in + tclTHENSEQ + [ + 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 "" (forward + (Some (prove_rec_arg_acc)) + (Genarg.IntroIdentifier acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + ); + observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids))); + observe_tac "h_fix" (h_fix (Some fix_id) (npost_rec_arg + 1)); + 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 -> + observe_tac "new_prove_with_tcc" + (new_prove_with_tcc + is_mes acc_inv fix_id tcc_lemma_ref (List.map mkVar 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 new file mode 100644 index 00000000..62eb528e --- /dev/null +++ b/contrib/funind/functional_principles_proofs.mli @@ -0,0 +1,19 @@ +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 new file mode 100644 index 00000000..8ad2e72b --- /dev/null +++ b/contrib/funind/functional_principles_types.ml @@ -0,0 +1,704 @@ +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 = Options.boxed_definitions() + } + in + ignore( + Declare.declare_constant + name + (Entries.DefinitionEntry ce, + Decl_kinds.IsDefinition (Decl_kinds.Scheme) + ) + ); + Options.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,_,_)) = + 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 _ _ _ -> ()) + in + incr i; + (* 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)); + Options.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 new file mode 100644 index 00000000..cf28c6e6 --- /dev/null +++ b/contrib/funind/functional_principles_types.mli @@ -0,0 +1,34 @@ +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/indfun.ml b/contrib/funind/indfun.ml new file mode 100644 index 00000000..6e2af224 --- /dev/null +++ b/contrib/funind/indfun.ml @@ -0,0 +1,747 @@ +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 + else Tactics.new_destruct + + +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 (out_some princ_option ) + with Failure "out_some" -> + (*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) (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' + pat) + 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,t)::bl -> + List.fold_right (fun x b -> Topconstr.mkLambdaC([x],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_soapp: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,([],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 build functional inversion principle" ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + with _ -> () + +let generate_principle + 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 (dummy_loc,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 -> + 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 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,Options.boxed_definitions (),Decl_kinds.Definition) + bl + None + body + (Some ret_type) + (fun _ _ -> ()) + | _ -> + Command.build_recursive fixpoint_exprl (Options.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.mkIdentC (id_of_string "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)],t)] -> t,x + | _ -> error "Recursive argument must be specified" + end + | Some wf_args -> + try + match + List.find + (function + | Topconstr.LocalRawAssum(l,t) -> + List.exists + (function (_,Name id) -> id = wf_args | _ -> false) + l + | _ -> false + ) + args + with + | Topconstr.LocalRawAssum(_,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)],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 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 + 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 + 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 names = + List.map + snd + (Topconstr.names_of_local_assums args) + in + let annot = + try Some (list_index (Name id) names - 1), 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 + (name,(Some 0, 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 + 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,b2) -> (nal,add_args id new_args b2)) nal, + add_args id new_args b1) + | CLambdaN(loc,nal,b1) -> + CLambdaN(loc, + List.map (fun (nal,b2) -> (nal,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,b_option,cel,cal) -> + CCases(loc,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,ck,b2) -> + CCast(loc,add_args id new_args b1,ck,add_args id new_args b2) + | CNotation _ -> anomaly "add_args : CNotation" + | 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,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)),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,ta) -> + (Topconstr.LocalRawAssum (nal,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 bl' = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_) -> nal + ) + bl + ) + in + let rec_id = + match List.nth bl' (out_some n) with + |(_,Name id) -> id | _ -> anomaly "" + 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 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 + [(id,None,nal_tas,t,b)] + in + do_generate_principle 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 true + + diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml new file mode 100644 index 00000000..13b242d5 --- /dev/null +++ b/contrib/funind/indfun_common.ml @@ -0,0 +1,508 @@ +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,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,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_reference + (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 = + Options.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 = !Options.raw_print in + Options.raw_print := true; + Impargs.make_implicit_args false; + Impargs.make_strict_implicit_args false; + Impargs.make_contextual_implicit_args false; + 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; + Options.raw_print := old_rawprint; + 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; + Options.raw_print := old_rawprint; + 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' = Util.option_smartmap do_subst_con finfos.equation_lemma in + let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in + let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in + let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in + let prop_lemma' = Util.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' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Util.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 := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ + str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ + str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ + str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ + str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ + str "prop_lemma := " ++ (Util.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 new file mode 100644 index 00000000..7da1d6f0 --- /dev/null +++ b/contrib/funind/indfun_common.mli @@ -0,0 +1,117 @@ +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/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 new file mode 100644 index 00000000..26a1066c --- /dev/null +++ b/contrib/funind/indfun_main.ml4 @@ -0,0 +1,467 @@ +(************************************************************************) +(* 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 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)) + + +ARGUMENT EXTEND fun_ind_using + TYPED AS constr_with_bindings_opt + 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 pat = + match pat with + | None -> IntroAnonymous + | Some pat -> pat + in + 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 pat = + match pat with + | None -> IntroAnonymous + | Some pat -> pat + in + 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 + +VERNAC ARGUMENT EXTEND 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 + + +VERNAC ARGUMENT EXTEND binder2 + [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> + [ + LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,c) ] +END + + +VERNAC ARGUMENT EXTEND rec_definition2 + [ ident(id) binder2_list( bl) + rec_annotation2_opt(annot) ":" lconstr( type_) + ":=" lconstr(def)] -> + [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_index (Name id) names - 1); 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 + (id, ni, bl, type_, def) ] + END + + +VERNAC ARGUMENT EXTEND rec_definitions2 +| [ rec_definition2(rd) ] -> [ [rd] ] +| [ rec_definition2(hd) "with" rec_definitions2(tl) ] -> [ hd::tl ] +END + + +VERNAC COMMAND EXTEND Function + ["Function" rec_definitions2(recsl)] -> + [ + do_generate_principle false recsl; + + ] +END + + +VERNAC ARGUMENT EXTEND fun_scheme_arg +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +END + +VERNAC ARGUMENT EXTEND fun_scheme_args +| [ fun_scheme_arg(fa) ] -> [ [fa] ] +| [ fun_scheme_arg(fa) "with" fun_scheme_args(fas) ] -> [fa::fas] +END + +VERNAC COMMAND EXTEND NewFunctionalScheme + ["Functional" "Scheme" fun_scheme_args(fas) ] -> + [ + try + Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + match fas with + | (_,fun_name,_)::_ -> + begin + make_graph (Nametab.global fun_name); + try Functional_principles_types.build_scheme fas + with Functional_principles_types.No_graph_found -> + Util.error ("Cannot generate induction principle(s)") + end + | _ -> assert false (* we can only have non empty list *) + ] +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 true (Name idunsafe) cstr allClauses) + (tclTHENFIRST + (Tactics.assert_as true IntroAnonymous (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 IntroAnonymous) 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" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> + [ + let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in + let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in + let id1,args1 = + try + let hd,args = destApp c1 in + if Term.isInd hd then hd , args + else raise (Util.error "Ill-formed (fst) argument") + with Invalid_argument _ + -> Util.error ("Bad argument form for merging schemes") in + let id2,args2 = + try + let hd,args = destApp c2 in + if isInd hd then hd , args + else raise (Util.error "Ill-formed (snd) argument") + with Invalid_argument _ + -> Util.error ("Bad argument form for merging schemes") in + (* TOFO: enlever le ignore et declarer l'inductif *) + ignore(Merge.merge c1 c2 args1 args2 id) + ] +END diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml new file mode 100644 index 00000000..04110ea9 --- /dev/null +++ b/contrib/funind/invfun.ml @@ -0,0 +1,993 @@ +(************************************************************************) +(* 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 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 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_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 = + try let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let v = tac g in msgnl (goal ++ fnl () ++ 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 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 -> 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 = 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([[],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,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,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" (forward + (Some (h_exact f_principle)) + (Genarg.IntroIdentifier principle_id) + princ_type); + 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_depedent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] +*) +let generalize_depedent_of x hyp g = + tclMAP + (function + | (id,None,t) when not (id = hyp) && + (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id] + | _ -> tclIDTAC + ) + (pf_hyps g) + 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 (v,Rawterm.NoBindings); + intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] + | _ -> reflexivity + with _ -> reflexivity + in + tclFIRST + [ reflexivity; + destruct_case () + ] + 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 + let eq_ind = Coqlib.build_coq_eq () 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 out_some (infos).equation_lemma + with Failure "out_some" -> 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 [([],Names.EvalConstRef (destConst f))] + in + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) + *) + let rec intros_with_rewrite_aux : tactic = + fun g -> + 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 isVar args.(1) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; + generalize_depedent_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 (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 + and intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g + 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 *) + (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 (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) + (fun i g -> 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, out_some 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 Genarg.IntroAnonymous (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(out_some 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" + | Failure "out_some" -> 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(out_some finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f1 f_correct g + with | Failure "" | Failure "out_some" | 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(out_some 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") + | Failure "out_some" -> + 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 new file mode 100644 index 00000000..1b796a81 --- /dev/null +++ b/contrib/funind/merge.ml @@ -0,0 +1,826 @@ +(************************************************************************) +(* 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 Util +open Topconstr +open Vernacexpr +open Pp +open Names +open Term +open Declarations +open Environ +open Rawterm +open Rawtermops + +(** {1 Utilities} *) + +(** {2 Useful operations on constr and rawconstr} *) + +(** 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 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 describe 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 + +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; + (* number of rec params of ind1 which remai rec param in merge *) + nrecprms1: int; + (* number of other rec params of ind1 (which become non parm) *) + notherprms1:int; + (* number of functional result params of ind2 (which become non parm) *) + nfunresprms1:int; + (* list of decl of rec parms from ind1 which remain parms *) + recprms1: rel_declaration list; + (* List of other rec parms from ind1 *) + otherprms1: rel_declaration list; (* parms that became args *) + funresprms1: rel_declaration list; (* parms that are functional result args *) + (* number of rec params of ind2 which remain rec param in merge (and not linked) *) + nrecprms2: int; + (* number of other params of ind2 (which become non rec parm) *) + notherprms2:int; + (* number of functional result params of ind2 (which become non parm) *) + nfunresprms2:int; + (* list of decl of rec parms from ind2 which remain parms (and not linked) *) + recprms2: rel_declaration list; + (* List of other rec parms from ind2 (which are linked or become non parm) *) + otherprms2: rel_declaration list; + funresprms2: rel_declaration list; (* parms that are functional result args *) + } + + +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 + +let isArg_stable x = match x with Arg_stable _ -> 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"; + () + + +(** {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 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) x -> + match mlnk.(i) with + | Prm_stable _ -> x::acc1 , acc2 , acc3 + | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3 + | Arg_funres -> acc1 , acc2 , x::acc3 + | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *) + ([],[],[]) arity_ctxt in + let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in + let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in + { + ident=id; + mib1=mib1; + oib1 = oib1; + mib2=mib2; + oib2 = oib2; + lnk1 = mlnk1; + lnk2 = mlnk2; + nrecprms1 = n_params1; + recprms1 = recprms1; + otherprms1 = otherprms1; + funresprms1 = funresprms1; + notherprms1 = Array.length mlnk1 - n_params1; + nfunresprms1 = List.length funresprms1; + nrecprms2 = n_params2; + recprms2 = recprms2; + otherprms2 = otherprms2; + funresprms2 = funresprms2; + notherprms2 = Array.length mlnk2 - n_params2; + nfunresprms2 = List.length funresprms2; + } + + + + +(** {1 Merging functions} *) + +exception NoMerge + +(* lnk is an link array of *all* args (from 1 and 2) *) +let 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 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 + | _ -> raise NoMerge + +let 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) + | _ -> raise NoMerge + + + +(* Heuristic when merging two lists of hypothesis: merge every rec + calls of nrach 1 with all rec calls of branch 2. *) +(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) +let onefoud = ref false (* Ugly *) + +let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) + filter_shift_stable = + match ltyp with + | [] -> [] + | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + let _ = onefoud := true in + let rechyps = + List.map + (fun (nme,ind) -> + match ind with + | RApp(_,i,args) -> + nme, merge_app_unsafe ind t shift filter_shift_stable + | _ -> assert false) + 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: (name * rawconstr) list) = + try + ignore + (List.map + (fun x -> + match x with + | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _ -> ()) + ltyp); + false + with Found _ -> true + +let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list) + concl1 (ltyp2:(name * rawconstr) list) concl2 + : (name * rawconstr) list * rawconstr = + let _ = prstr "MERGE_TYPES\n" in + let _ = prstr "ltyp 1 : " in + let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in + let _ = prstr "\nltyp 2 : " in + let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in + let _ = prstr "\n" in + + + let res = + match ltyp1 with + | [] -> + let isrec1 = (accrec1<>[]) in + let isrec2 = find_app ind2name ltyp2 in + let _ = if isrec2 then prstr " ISREC2 TRUE" else prstr " ISREC2 FALSE" in + let _ = if isrec1 then prstr " ISREC1 TRUE\n" else prstr " ISREC1 FALSE\n" in + let rechyps = + if isrec1 && isrec2 + then merge_rec_hyps shift accrec1 ltyp2 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",concl2]) + filter_shift_stable + else if isrec2 + then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2 + filter_shift_stable_right + else [] in + let _ = prstr"\nrechyps : " in + let _ = List.iter + (fun (nm,tp) -> prNamedRConstr (string_of_name nm) 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,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,t1) :: recres) , recconcl2 + 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,y) -> id_of_name x) allargs1)) in + let allargs2 = + Array.of_list (List.rev (List.map (fun (x,y) -> 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' -> ... + -> (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_n nargs1 typcstr1 in + let allargs2,rest2 = raw_decompose_prod_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 rest1 in + let hyps2,concl2' = raw_decompose_prod rest2 in + let ltyp,concl2 = + merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in + let typ = raw_compose_prod concl2 (List.rev ltyp) in + let revargs1 = + list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in + let revargs2 = + list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in + let typwithprms = raw_compose_prod 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 * types) list) + (typcstr2:(identifier * types) list) : (identifier * rawconstr) list = + List.flatten + (List.map + (fun (id1,typ1) -> + let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in + let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in + let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in + List.map + (fun (id2,typ2) -> + let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in + (* Avoid also rawtyp1 names *) + let avoid2 = Idset.union avoid idsoftyp1 in + let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in + let typ = merge_one_constructor shift rawtyp1 rawtyp2 in + let newcstror_id = merge_constructor_id id1 id2 shift 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) : (identifier * rawconstr) list = + let lcstr1 = Array.to_list oib1.mind_user_lc in + let lcstr2 = Array.to_list oib2.mind_user_lc 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(); + merge_constructors shift avoid lcstr1 lcstr2 + +(** [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 prms_decl mkProp in + let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in + let res,_ = raw_decompose_prod dummy_rawconstr in + res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) + +(** [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. *) + let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *) + let prms1 = (* rec uniform parms of mib1 *) + List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in + + (* useless: *) + let prms1_named,avoid' = build_raw_params prms1 [] in + let prms2_named,avoid = build_raw_params prms1 avoid' in + let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in + (* *** *) + + merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) + + + +let merge_rec_params_and_arity params1 params2 shift (concl:constr) = + let params = shift.recprms1 @ shift.recprms2 in + let resparams, _ = + List.fold_left + (fun (acc,env) (nme,_,tp) -> + let typ = Constrextern.extern_constr false env tp in + let newenv = Environ.push_rel (nme,None,tp) env in + LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv) + ([],Global.env()) + 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)],typ] , acc) , newenv) + (concl,Global.env()) + (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) 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 mib1 mib2 shift + (rawlist:(identifier * rawconstr) list):inductive_expr = + let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) + Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in + let lident = dummy_loc, shift.ident in + let bindlist , cstr_expr = (* params , arities *) + merge_rec_params_and_arity + mib1.mind_params_ctxt mib2.mind_params_ctxt 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 , cstr_expr , lcstor_expr + +(** [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 rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in + let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in + (* Declare inductive *) + Command.build_mutual [(indexpr,None)] true (* means: not coinductive *) + + + +let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id = + let env = Global.env() in + let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in + let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in + let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *) + Array.mapi (fun i c -> Unlinked) args1 in + let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *) + 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 + let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *) + let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in + resa + + + + + +(* @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 new file mode 100644 index 00000000..aca84f06 --- /dev/null +++ b/contrib/funind/rawterm_to_relation.ml @@ -0,0 +1,1251 @@ +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 = Util.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(Libnames.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_tuple) + (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,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,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,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)],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)], Constrextern.extern_rawconstr Idset.empty t) + ) + rels_params + in + let ext_rels_constructors = + Array.map (List.map + (fun (id,t) -> + false,((dummy_loc,id), + Options.with_option + Options.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, + 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 (Options.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 msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,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 msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,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 new file mode 100644 index 00000000..0075fb0a --- /dev/null +++ b/contrib/funind/rawterm_to_relation.mli @@ -0,0 +1,16 @@ + + + +(* + [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 new file mode 100644 index 00000000..ba5c2bbd --- /dev/null +++ b/contrib/funind/rawtermops.ml @@ -0,0 +1,671 @@ +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,t,b) +let mkRProd(n,t,b) = RProd(dummy_loc,n,t,b) +let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) +let mkRCases(rto,l,brl) = RCases(dummy_loc,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,CastCoerce,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,t,b) -> + raw_decompose_prod ((n,t)::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_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_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,t,b) -> + RLambda(loc, + name, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) + | RProd(loc,name,t,b) -> + RProd(loc, + name, + 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,infos,el,brl) -> + RCases(loc, + 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,k,t) -> + RCast(loc,change_vars mapping b,k,change_vars mapping t) + | 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,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,new_t,new_b) + | RProd(loc,Anonymous,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + RProd(loc,Anonymous,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,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,new_t,new_b) + | RProd(loc,Name id,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,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,infos,el,brl) -> + let new_el = + List.map (function (rt,i) -> alpha_rt excluded rt, i) el + in + RCases(loc,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,k,t) -> + RCast(loc,alpha_rt excluded b,k,alpha_rt excluded t) + | 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,_,t) -> is_free_in b || is_free_in t + | 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,t,b) -> + RLambda(loc, + name, + replace_var_by_pattern t, + replace_var_by_pattern b + ) + | RProd(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | RProd(loc,name,t,b) -> + RProd(loc, + name, + 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,infos,el,brl) -> + RCases(loc, + 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,k,t) -> + RCast(loc,replace_var_by_pattern b,k,replace_var_by_pattern t) + | 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,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RProd (loc,na,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,k,t) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ 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,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,t,b) -> + RLambda(loc, + name, + zeta_normalize_term t, + zeta_normalize_term b + ) + | RProd(loc,name,t,b) -> + RProd(loc, + name, + 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,infos,el,brl) -> + RCases(loc, + 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,k,t) -> + RCast(loc,zeta_normalize_term b,k,zeta_normalize_term t) + | 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,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b) + | RProd(loc,na,t,b) -> RProd(loc,na,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,kind,t) -> RCast(loc,expand_as map b,kind,expand_as map t) + | RCases(loc,po,el,brl) -> + RCases(loc, 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 new file mode 100644 index 00000000..9647640c --- /dev/null +++ b/contrib/funind/rawtermops.mli @@ -0,0 +1,120 @@ +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_tuple * 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_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_compose_prod : rawconstr -> (Names.name*rawconstr) 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/tacinv.ml4 b/contrib/funind/tacinv.ml4 index 1500e1ae..5d19079b 100644 --- a/contrib/funind/tacinv.ml4 +++ b/contrib/funind/tacinv.ml4 @@ -1,16 +1,10 @@ (*i camlp4deps: "parsing/grammar.cma" i*) (*s FunInv Tactic: inversion following the shape of a function. *) -(* Use: - \begin{itemize} - \item The Tacinv directory must be in the path (-I <path> option) - \item use the bytecode version of coqtop or coqc (-byte option), or make a - coqtop - \item Do [Require Tacinv] to be able to use it. - \item For syntax see Tacinv.v - \end{itemize} -*) +(* Deprecated: see indfun_main.ml4 instead *) + +(* Don't delete this file yet, it may be used for other purposes *) (*i*) open Termops @@ -46,6 +40,8 @@ let smap_to_list m = Smap.fold (fun c cb l -> (c,cb)::l) m [] let merge_smap m1 m2 = Smap.fold (fun c cb m -> Smap.add c cb m) m1 m2 let rec listsuf i l = if i<=0 then l else listsuf (i-1) (List.tl l) let rec listpref i l = if i<=0 then [] else List.hd l :: listpref (i-1) (List.tl l) +let rec split3 l = + List.fold_right (fun (e1,e2,e3) (a,b,c) -> (e1::a),(e2::b),(e3::c)) l ([],[],[]) let mkthesort = mkProp (* would like to put Type here, but with which index? *) @@ -56,9 +52,7 @@ let equality_hyp_string = "_eg_" (* bug de refine: on doit ssavoir sur quelle hypothese on se trouve. valeur initiale au debut de l'appel a la fonction proofPrinc: 1. *) let nthhyp = ref 1 - (*debugging*) - (* let rewrules = ref [] *) - (*debugging*) + let debug i = prstr ("DEBUG "^ string_of_int i ^"\n") let pr2constr = (fun c1 c2 -> prconstr c1; prstr " <---> "; prconstr c2) (* Operations on names *) @@ -71,21 +65,6 @@ let string_of_name nme = string_of_id (id_of_name nme) (* Interpretation of constr's *) let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c -let rec collect_cases l = - match l with - | [||] -> [||],[],[],[||],[||],[] - | arr -> - let (a,c,d,f,e,g)= arr.(0) in - let aa,lc,ld,_,_,_ = - collect_cases (Array.sub arr 1 ((Array.length arr)-1)) in - Array.append [|a|] aa , (c@lc) , (d@ld) , f , e, g - -let rec collect_pred l = - match l with - | [] -> [],[],[] - | (e1,e2,e3)::l' -> let a,b,c = collect_pred l' in (e1::a),(e2::b),(e3::c) - - (*s specific manipulations on constr *) let lift1_leqs leq= List.map @@ -194,29 +173,25 @@ let applFull c typofc = let res = mkAppRel c ltyp (List.length ltyp) in res - +(* Take two terms with same structure and return a map of deBruijn from the + first to the second. Only DeBruijn should be different between the two + terms. *) let rec build_rel_map typ type_of_b = match (kind_of_term typ), (kind_of_term type_of_b) with Evar _ , Evar _ -> Smap.empty - | Rel i, Rel j -> if i=j then Smap.empty - else Smap.add typ type_of_b Smap.empty + | Const c1, Const c2 when c1=c2 -> Smap.empty + | Ind c1, Ind c2 when c1=c2 -> Smap.empty + | Rel i, Rel j when i=j -> Smap.empty + | Rel i, Rel j -> Smap.add typ type_of_b Smap.empty | Prod (name,c1,c2), Prod (nameb,c1b,c2b) -> let map1 = build_rel_map c1 c1b in let map2 = build_rel_map (pop c2) (pop c2b) in merge_smap map1 map2 - | App (f,args), App (fb,argsb) -> - (try build_rel_map_list (Array.to_list args) (Array.to_list argsb) - with Invalid_argument _ -> - failwith ("Could not generate case annotation. "^ - "Two application with different length")) - | Const c1, Const c2 -> if c1=c2 then Smap.empty - else failwith ("Could not generate case annotation. "^ - "Two different constants in a case annotation.") - | Ind c1, Ind c2 -> if c1=c2 then Smap.empty - else failwith ("Could not generate case annotation. "^ - "Two different constants in a case annotation.") + | App (f,args), App (fb,argsb) when Array.length args = Array.length argsb -> + build_rel_map_list (Array.to_list args) (Array.to_list argsb) | _,_ -> failwith ("Could not generate case annotation. "^ "Incompatibility between annotation and actual type") + and build_rel_map_list ltyp ltype_of_b = List.fold_left2 (fun a b c -> merge_smap a (build_rel_map b c)) Smap.empty ltyp ltype_of_b @@ -224,299 +199,235 @@ and build_rel_map_list ltyp ltype_of_b = (*s Use (and proof) of the principle *) -(* - \begin {itemize} - \item [concl] ([constr]): conclusions, cad (xi:ti)gl, ou gl est le but a - prouver, et xi:ti correspondent aux arguments donnés à la tactique. On - enlève un produit à chaque fois qu'on rencontre un binder, sans lift ou pop. - Initialement: une seule conclusion, puis specifique a chaque branche. - \item[absconcl] ([constr array]): les conclusions (un predicat pour chaque - fixp. mutuel) patternisées pour pouvoir être appliquées. - \item [mimick] ([constr]): le terme qu'on imite. On plonge dedans au fur et - à mesure, sans lift ni pop. - \item [nmefonc] ([constr array]): la constante correspondant à la fonction - appelée, permet de remplacer les appels recursifs par des appels à la - constante correspondante (non pertinent (et inutile) si on permet l'appel de - la tactique sur une terme donné directement (au lieu d'une constante comme - pour l'instant)). - \item [fonc] ([int*int]) : bornes des indices des variable correspondant aux - appels récursifs (plusieurs car fixp. mutuels), utile pour reconnaître les - appels récursifs (ATTENTION: initialement vide, reste vide tant qu'on n'est - pas dans un fix). - \end{itemize} -*) +(* This is the type of the argument of [proofPrinc] *) type mimickinfo = { - concl: constr; - absconcl: constr array; - mimick: constr; - env: env; - sigma: Evd.evar_map; - nmefonc: constr array; - fonc: int * int; + concl: constr; (* conclusion voulue, cad (xi:ti)gl, ou gl est le but a + prouver, et xi:ti correspondent aux arguments donnés à + la tactique. On enlèvera un produit à chaque fois + qu'on rencontrera un binder, sans lift ou pop. + Initialement: une seule conclusion, puis specifique à + chaque branche. *) + absconcl: constr array; (* conclusions patternisées pour pouvoir être + appliquées = un predicat pour chaque fixpt + mutuel. *) + mimick: constr; (* le terme qu'on imite. On plongera dedans au fur et + à mesure, sans lift ni pop. *) + env: env; (* The global typing environment, we will add thing in it when + going inside the term (push_rel, push_rec_types) *) + sigma: Evd.evar_map; + nmefonc: constr array; (* la constante correspondant à la fonction + appelée, permet de remplacer les appels + recursifs par des appels à la constante + correspondante (non pertinent (et inutile) si + on permet l'appel de la tactique sur une terme + donné directement (au lieu d'une constante + comme pour l'instant)). *) + fonc: int * int; (* bornes des indices des variable correspondant aux + appels récursifs (plusieurs car fixp. mutuels), + utile pour reconnaître les appels récursifs + (ATTENTION: initialement vide, reste vide tant qu'on + n'est pas dans un fix). *) doeqs: bool; (* this reference is to toggle building of equalities during the building of the principle (default is true) *) - fix: bool (* did I already went through a fix or case constr? lambdas + fix: bool; (* did I already went through a fix or case constr? lambdas found before a case or a fix are treated as parameters of the induction principle *) + lst_vars: (constr*(name*constr)) list ; (* Variables rencontrées jusque là *) + lst_eqs: (Term.constr * (Term.constr * Term.constr * Term.constr)) list ; + (* liste d'équations engendrées au cours du + parcours, cette liste grandit à chaque + case, et il faut lifter le tout à chaque + binder *) + lst_recs: constr list ; (* appels récursifs rencontrés jusque là *) } -(* - \begin{itemize} - \item [lst_vars] ([(constr*(name*constr)) list]): liste des variables - rencontrées jusqu'à maintenant. - \item [lst_eqs] ([constr list]): liste d'équations engendrées au cours du - parcours, cette liste grandit à chaque case, et il faut lifter le tout à - chaque binder. - \item [lst_recs] ([constr list]): listes des appels récursifs rencontrés - jusque là. - \end{itemize} - - Cette fonction rends un nuplet de la forme: - - [t, - [(ev1,tev1);(ev2,tev2)..], - [(i1,j1,k1);(i2,j2,k2)..], - [|c1;c2..|], - [|typ1;typ2..|], - [(param,tparam)..]] - - *) - -(* This could be the return type of [proofPrinc], but not yet *) -type funind = +(* This is the return type of [proofPrinc] *) +type 'a funind = (* 'A = CONTR OU CONSTR ARRAY *) { - princ:constr; - evarlist: (constr*Term.types) list; - hypnum: (int*int*int) list; - mutfixmetas: constr array ; - conclarray: types array; - params:(constr*name*constr) list + + princ:'a; (* le (ou les) principe(s) demandé(s), il contient des meta + variables représentant soit des trous à prouver plus tard, + soit les conclusions à compléter avant de rendre le terme + (suivant qu'on utilise le principe pour faire refine ou + functional scheme). Il y plusieurs conclusions si plusieurs + fonction mutuellement récursives) voir la suite. *) + evarlist: (constr*Term.types) list; (* [(ev1,tev1);(ev2,tev2)...]] + l'ensemble des meta variables + correspondant à des trous. [evi] + est la meta variable, [tevi] est + son type. *) + hypnum: (int*int*int) list; (* [[(in,jn,kn)...]] sont les nombres + respectivement de variables, d'équations, + et d'hypothèses de récurrence pour le but + n. Permet de faire le bon nombre d'intros + et des rewrite au bons endroits dans la + suite. *) + mutfixmetas: constr array ; (* un tableau de meta variables correspondant + à chacun des prédicats mutuellement + récursifs construits. *) + conclarray: types array; (* un tableau contenant les conclusions + respectives de chacun des prédicats + mutuellement récursifs. Permet de finir la + construction du principe. *) + params:(constr*name*constr) list; (* [[(metavar,param,tparam)..]] la + liste des paramètres (les lambdas + au-dessus du fix) du fixpoint si + fixpoint il y a, le paramètre est + une meta var, dont on stocke le nom + et le type. TODO: utiliser la + structure adequat? *) } -(* - où: - \begin{itemize} - \item[t] est le principe demandé, il contient des meta variables - représentant soit des trous à prouver plus tard, soit les conclusions à - compléter avant de rendre le terme (suivant qu'on utilise le principe pour - faire refine ou functional scheme). Il y plusieurs conclusions si plusieurs - fonction mutuellement récursives) voir la suite. +let empty_funind_constr = + { + princ = mkProp; + evarlist = []; + hypnum = []; + mutfixmetas = [||]; + conclarray = [||]; + params = [] + } - \item[[(ev1,tev1);(ev2,tev2)...]] est l'ensemble des méta variables - correspondant à des trous. [evi] est la meta variable, [tevi] est son type. +let empty_funind_array = + { empty_funind_constr with + princ = [||]; + } - \item[(in,jn,kn)] sont les nombres respectivement de variables, d'équations, - et d'hypothèses de récurrence pour le but n. Permet de faire le bon nombre - d'intros et des rewrite au bons endroits dans la suite. +(* Replace the calls to the function (recursive calls) by calls to the + corresponding constant *) +let replace_reccalls mi b = + let d,f = mi.fonc in + let res = ref b in + let _ = for i = d to f do + res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in + !res + - \item[[|c1;c2...|]] est un tableau de meta variables correspondant à chacun - des prédicats mutuellement récursifs construits. - \item[[|typ1;typ2...|]] est un tableau contenant les conclusions respectives - de chacun des prédicats mutuellement récursifs. Permet de finir la - construction du principe. +(* collects all information of match branches stored in [l] *) +let rec collect_cases l = + match l with + | [||] -> empty_funind_array + | arr -> + let x = arr.(0) in + let resrec = collect_cases (Array.sub arr 1 (Array.length arr - 1)) in + { x with + princ= Array.append [|x.princ|] resrec.princ; + evarlist = x.evarlist@resrec.evarlist; + hypnum = x.hypnum@resrec.hypnum; + } + +let collect_pred l = + let l1,l2,l3 = split3 l in + Array.of_list l1 , Array.of_list l2 , Array.of_list l3 + + +(* [build_pred n tarr] builds the right predicates for each element of [tarr] + (of type: [type array] of size [n]). Return the list of triples: + (?i , + fun (x1:t1) ... (xn:tn) => (?i x1...xn) , + forall (x1:t1) ... (xn:tn), (?i x1...xn)), + where ti's are deduced from elements of tarr, which are of the form: + t1 -> t2 -> ... -> tn -> <nevermind>. *) +let rec build_pred n tarr = + if n >= Array.length tarr (* iarr *) then [] + else + let ftyp = Array.get tarr n in + let gl = mknewmeta() in + let gl_app = applFull gl ftyp in + let pis = prod_change_concl ftyp gl_app in + let gl_abstr = lam_change_concl ftyp gl_app in + (gl,gl_abstr,pis):: build_pred (n+1) tarr - \item[[(param,tparam)..]] est la liste des paramètres (les lambda au-dessus - du fix) du fixpoint si fixpoint il y a. - \end{itemize} -*) let heq_prefix = "H_eq_" type kind_of_hyp = Var | Eq (*| Rec*) -let rec proofPrinc mi lst_vars lst_eqs lst_recs: - constr * (constr*Term.types) list * (int*int*int) list - * constr array * types array * (constr*name*constr) list = +(* the main function, build the principle by exploring the term and reproduce + the same structure. *) +let rec proofPrinc mi: constr funind = match kind_of_term mi.mimick with (* Fixpoint: we reproduce the Fix, fonc becomes (1,nbofmutf) to point on the name of recursive calls *) | Fix((iarr,i),(narr,tarr,carr)) -> - - (* We construct the right predicates for each mutual fixpt *) - let rec build_pred n = - if n >= Array.length iarr then [] - else - let ftyp = Array.get tarr n in - let gl = mknewmeta() in - let gl_app = applFull gl ftyp in - let pis = prod_change_concl ftyp gl_app in - let gl_abstr = lam_change_concl ftyp gl_app in - (gl,gl_abstr,pis):: build_pred (n+1) in - - let evarl,predl,pisl = collect_pred (build_pred 0) in - let newabsconcl = Array.of_list predl in - let evararr = Array.of_list evarl in - let pisarr = Array.of_list pisl in + (* We construct the right predicates for each mutual fixpt *) + let evararr,newabsconcl,pisarr = collect_pred (build_pred 0 tarr) in let newenv = push_rec_types (narr,tarr,carr) mi.env in - - let rec collect_fix n = - if n >= Array.length iarr then [],[],[],[] - else - let nme = Array.get narr n in - let c = Array.get carr n in - (* rappelle sur le sous-terme, on ajoute un niveau de - profondeur (lift) parce que Fix est un binder. *) - let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl; - mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true} in - let appel_rec,levar,lposeq,_,evarrarr,parms = - proofPrinc newmi (lift1_lvars lst_vars) - (lift1_leqs lst_eqs) (lift1L lst_recs) in - let lnme,lappel_rec,llevar,llposeq = collect_fix (n+1) in - (nme::lnme),(appel_rec::lappel_rec),(levar@llevar), (lposeq@llposeq) in - - let lnme,lappel_rec,llevar,llposeq =collect_fix 0 in - let lnme' = List.map (fun nme -> newname_append nme "_ind") lnme in - let anme = Array.of_list lnme' in - let aappel_rec = Array.of_list lappel_rec in - (* llevar are put outside the fix, so one level of rel must be removed *) - mkFix((iarr,i),(anme, pisarr,aappel_rec)) - , (pop1_levar llevar) , llposeq,evararr,pisarr,[] - + let anme',aappel_rec,llevar,llposeq = + collect_fix mi 0 iarr narr carr pisarr newabsconcl newenv in + let anme = Array.map (fun nme -> newname_append nme "_ind") anme' in + { + princ = mkFix((iarr,i),(anme, pisarr,aappel_rec)); + evarlist= pop1_levar llevar; (* llevar are put outside the fix, so we pop 1 *) + hypnum = llposeq; + mutfixmetas = evararr; + conclarray = pisarr; + params = [] + } (* <pcase> Cases b of arrPt end.*) - | Case(cinfo, pcase, b, arrPt) -> - + | Case (cinfo, pcase, b, arrPt) -> let prod_pcase,_ = decompose_lam pcase in - let nmeb,lastprod_pcase = List.hd prod_pcase in - let b'= apply_leqtrpl_t b lst_eqs in + let _nmeb,_ = List.hd prod_pcase in + let newb'= apply_leqtrpl_t b mi.lst_eqs in let type_of_b = Typing.type_of mi.env mi.sigma b in - let new_lst_recs = lst_recs @ hdMatchSub_cpl b mi.fonc in - (* Replace the calls to the function (recursive calls) by calls to the - corresponding constant: *) - let d,f = mi.fonc in - let res = ref b' in - let _ = for i = d to f do - res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in - let newb = !res in - - (* [fold_proof t l n] rend le resultat de l'appel recursif sur les - elements de la liste l (correpsondant a arrPt), appele avec les bons - arguments: [concl] devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] - est le nombre d'arguments du constructeur considéré (FIX: Hormis les - parametres!!), et [concl'] est concl ou l'on a réécrit [b] en ($c_n$ - [rel1]...).*) - - let rec fold_proof nth_construct eltPt' = - (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3 - x2 x1... ], sans quoi les annotations ne sont plus coherentes *) - let cstr_appl,nargs = nth_dep_constructor type_of_b nth_construct in - let concl'' = - substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in - let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in - let concl_dummy = add_n_dummy_prod concl'' nargs in - let lsteqs_rew = apply_eq_leqtrpl lst_eqs neweq in - let new_lsteqs = - (mkRel (0-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in - let a',a'' = decompose_lam_n nargs eltPt' in - let newa'' = - if mi.doeqs - then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') - else a'' in - let newmimick = lamn nargs a' newa'' in - let b',b'' = decompose_prod_n nargs concl_dummy in - let newb'' = - if mi.doeqs - then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'') - else b'' in - let newconcl = prodn nargs b' newb'' in - let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true} in - let a,b,c,d,e,p = proofPrinc newmi lst_vars new_lsteqs new_lst_recs in - a,b,c,d,e,p - in - - let arrPt_proof,levar,lposeq,evararr,absc,_ = - collect_cases (Array.mapi fold_proof arrPt) in - let prod_pcase,concl_pcase = decompose_lam pcase in - let nme,typ = List.hd prod_pcase in - let suppllam_pcase = List.tl prod_pcase in - (* je remplace b par rel1 (apres avoir lifte un coup) dans la - future annotation du futur case: ensuite je mettrai un lambda devant *) - let typesofeqs' = eqs_of_beqs_named equality_hyp_string lst_eqs in - (* let typesofeqs = prod_it_lift typesofeqs' mi.concl in *) - let typesofeqs = mi.concl in - let typeof_case'' = - substitterm 0 (lift 1 b) (mkRel 1) (lift 1 typesofeqs) in - - (* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant - le piquant du case [pcase] contient des lambdas supplémentaires en tête - je les ai dans la variable [suppllam_pcase]. Le problème est que la - conclusion du piquant doit faire référence à ces variables plutôt qu'à - celle de l'exterieur. Ce qui suit permet de changer les reference de - newpacse' pour pointer vers les lambda du piquant. On procède comme - suit: on repère les rels qui pointent à l'interieur du piquant dans la - fonction imitée, pour ça on parcourt le dernier lambda du piquant (qui - contient le type de l'argument du case), et on remplace les rels - correspondant dans la preuve construite. *) - - (* typ vient du piquant, type_of_b vient du typage de b.*) - - let rel_smap = - if List.length suppllam_pcase=0 then Smap.empty else - build_rel_map (lift (List.length suppllam_pcase) type_of_b) typ in - let rel_map = smap_to_list rel_smap in - let rec substL l c = - match l with - [] -> c - | ((e,e') ::l') -> substL l' (substitterm 0 e (lift 1 e') c) in - let newpcase' = substL rel_map typeof_case'' in - let neweq = mkEq (lift (List.length suppllam_pcase + 1) type_of_b) - (lift (List.length suppllam_pcase + 1) newb) (mkRel 1) in - let newpcase = - if mi.doeqs then - mkProd (name_of_string "eg", neweq, lift 1 newpcase') else newpcase' - in - (* construction du dernier lambda du piquant. *) - let typeof_case' = mkLambda (newname_append nme "_ind" ,typ, newpcase) in - (* ajout des lambdas supplémentaires (type dépendant) du piquant. *) - let typeof_case = - lamn (List.length suppllam_pcase) suppllam_pcase typeof_case' in - let trm' = mkCase (cinfo,typeof_case,newb, arrPt_proof) in - let trm = - if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) - else trm' in - trm,levar,lposeq,evararr,absc,[] (* fix parms here (fix inside case)*) - + (* Replace the recursive calls to the function by calls to the constant *) + let newb = replace_reccalls mi newb' in + let cases = collect_cases (Array.mapi (fold_proof mi b type_of_b newb) arrPt) in + (* the match (case) annotation must be transformed, see [build_pcase] below *) + let newpcase = build_pcase mi pcase b type_of_b newb in + let trm' = mkCase (cinfo,newpcase,newb, cases.princ) in + { cases with + princ = if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) else trm'; + params = [] (* FIX: fix parms here (fixpt inside a match)*) + } + + | Lambda(nme, typ, cstr) -> let _, _, cconcl = destProd mi.concl in let d,f=mi.fonc in let newenv = push_rel (nme,None,typ) mi.env in - let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv; - fonc=((if d > 0 then d+1 else 0),(if f > 0 then f+1 else 0))} in let newlst_var = (* if this lambda is a param, then don't add it here *) - if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars lst_vars - else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars lst_vars in - let rec_call,levar,lposeq,evararr,absc,parms = - proofPrinc newmi newlst_var (lift1_leqs lst_eqs) (lift1L lst_recs) in + if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars mi.lst_vars + else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars mi.lst_vars in + let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv; + fonc = (if d > 0 then d+1 else 0) , (if f > 0 then f+1 else 0); + lst_vars = newlst_var ; lst_eqs = lift1_leqs mi.lst_eqs; + lst_recs = lift1L mi.lst_recs} in + let resrec = proofPrinc newmi in (* are we inside a fixpoint or a case? then this is a normal lambda *) - if mi.fix then mkLambda (nme,typ,rec_call) , levar, lposeq,evararr,absc,[] + if mi.fix + then { resrec with princ = mkLambda (nme,typ,resrec.princ) ; params = [] } else (* otherwise this is a parameter *) let metav = mknewmeta() in let substmeta t = popn 1 (substitterm 0 (mkRel 1) metav t) in - let newrec_call = substmeta rec_call in - let newlevar = List.map (fun (ev,tev) -> ev, substmeta tev) levar in - let newabsc = Array.map substmeta absc in - newrec_call,newlevar,lposeq,evararr,newabsc,((metav,nme, typ)::parms) + { resrec with + princ = substmeta resrec.princ; + evarlist = List.map (fun (ev,tev) -> ev, substmeta tev) resrec.evarlist; + conclarray = Array.map substmeta resrec.conclarray; + params = (metav,nme,typ) :: resrec.params + } + | LetIn(nme,cstr1, typ, cstr) -> failwith ("I don't deal with let ins yet. "^ "Please expand them before applying this function.") | u -> - let varrels = List.rev (List.map fst lst_vars) in - let varnames = List.map snd lst_vars in + let varrels = List.rev (List.map fst mi.lst_vars) in + let varnames = List.map snd mi.lst_vars in let nb_vars = List.length varnames in - let nb_eqs = List.length lst_eqs in - let eqrels = List.map fst lst_eqs in + let nb_eqs = List.length mi.lst_eqs in + let _eqrels = List.map fst mi.lst_eqs in (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs trouvés dans les let in et les Cases avec ceux trouves dans u (ie mi.mimick). *) (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *) - let terms_recs = lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in - + let terms_recs = mi.lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in (*c construction du terme: application successive des variables, des egalites et des appels rec, a la variable existentielle correspondant a l'hypothese de recurrence en cours. *) @@ -527,18 +438,110 @@ let rec proofPrinc mi lst_vars lst_eqs lst_recs: let appsrecpred = exchange_reli_arrayi_L mi.absconcl mi.fonc terms_recs in let typeofhole'' = prod_it_anonym_lift mi.concl appsrecpred in let typeofhole = prodn nb_vars varnames typeofhole'' in - (* Un bug de refine m'oblige à mettre ici un H (meta variable à ce point, mais remplacé par H avant le refine) au lieu d'un '?', je mettrai les '?' à la fin comme ça [(([H1,H2,H3...] ...) ? ? ?)] *) - let newmeta = mknewmeta() in let concl_with_var = applistc newmeta varrels in let conclrecs = applistc concl_with_var terms_recs in - conclrecs,[newmeta,typeofhole], [nb_vars,(List.length terms_recs) - ,nb_eqs],[||],mi.absconcl,[] - + { empty_funind_constr with + princ = conclrecs; + evarlist = [ newmeta , typeofhole ]; + hypnum = [ nb_vars , List.length terms_recs , nb_eqs ]; + conclarray = mi.absconcl; + } + +(* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant + l'annotation de type du case [pcase] contient des lambdas supplémentaires + en tête. Je les récupère dans la variable [suppllam_pcase]. Le problème est + que la conclusion de l'annotation du nouveauacse doit faire référence à ces + variables plutôt qu'à celle de l'exterieur. Ce qui suit permet de changer + les reference de newpcase' pour pointer vers les lambda du piquant. On + procède comme suit: on repère les rels qui pointent à l'interieur de + l'annotation dans la fonction initiale et on les relie à celle du type + voulu pour le case, pour ça ([build_rel_map]) on parcourt en même temps le + dernier lambda du piquant ([typ]) (qui contient le type de l'argument du + case) et le type attendu pour le case ([type_of_b]) et on construit un + map. Ensuite on remplace les rels correspondant dans la preuve construite + en suivant le map. *) + +and build_pcase mi pcase b type_of_b newb = + let prod_pcase,_ = decompose_lam pcase in + let nme,typ = List.hd prod_pcase in + (* je remplace b par rel1 (apres avoir lifte un coup) dans la future + annotation du futur case: ensuite je mettrai un lambda devant *) + let typeof_case'' = substitterm 0 (lift 1 b) (mkRel 1) (lift 1 mi.concl) in + let suppllam_pcase = List.tl prod_pcase in + let suppllam_pcasel = List.length suppllam_pcase in + let rel_smap = + if suppllam_pcasel=0 then Smap.empty else (* FIX: is this test necessary ? *) + build_rel_map (lift suppllam_pcasel type_of_b) typ in + let newpcase''' = + Smap.fold (fun e e' acc -> substitterm 0 e (lift 1 e') acc) + rel_smap typeof_case'' in + let neweq = mkEq (lift (suppllam_pcasel + 1) type_of_b) + (lift (suppllam_pcasel + 1) newb) (mkRel 1) in + let newpcase'' = + if mi.doeqs + then mkProd (name_of_string "eg", neweq, lift 1 newpcase''') + else newpcase''' in + (* construction du dernier lambda du piquant. *) + let newpcase' = mkLambda (newname_append nme "_ind" ,typ, newpcase'') in + (* ajout des lambdas supplémentaires (type dépendant) du piquant. *) + lamn suppllam_pcasel suppllam_pcase newpcase' + + +(* [fold_proof mi b typeofb newb l n] rend le resultat de l'appel recursif sur + cstr (correpsondant au ième elt de [arrPt] ci-dessus et donc au ième + constructeur de [typeofb]), appele avec les bons arguments: [mi.concl] + devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] est le nombre d'arguments + du constructeur considéré, et [concl'] est [mi.concl] ou l'on a réécrit [b] + en ($c_n$ [rel1]...). *) +and fold_proof mi b type_of_b newb i cstr = + let new_lst_recs = mi.lst_recs @ hdMatchSub_cpl b mi.fonc in + (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3 + x2 x1... ], sans quoi les annotations ne sont plus coherentes *) + let cstr_appl,nargs = nth_dep_constructor type_of_b i in + let concl'' = + substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in + let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in + let concl_dummy = add_n_dummy_prod concl'' nargs in + let lsteqs_rew = apply_eq_leqtrpl mi.lst_eqs neweq in + let new_lsteqs = (mkRel (-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in + let a',a'' = decompose_lam_n nargs cstr in + let newa'' = + if mi.doeqs + then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'') + else a'' in + let newmimick = lamn nargs a' newa'' in + let b',b'' = decompose_prod_n nargs concl_dummy in + let newb'' = + if mi.doeqs + then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'') + else b'' in + let newconcl = prodn nargs b' newb'' in + let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true; + lst_eqs= new_lsteqs; lst_recs = new_lst_recs} in + proofPrinc newmi + + +and collect_fix mi n iarr narr carr pisarr newabsconcl newenv = + if n >= Array.length iarr then [||],[||],[],[] + else + let nme = Array.get narr n in + let c = Array.get carr n in + (* rappelle sur le sous-terme, on ajoute un niveau de + profondeur (lift) parce que Fix est un binder. *) + let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl; + mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true; + lst_vars=lift1_lvars mi.lst_vars; lst_eqs=lift1_leqs mi.lst_eqs; + lst_recs= lift1L mi.lst_recs;} in + let resrec = proofPrinc newmi in + let lnme,lappel_rec,llevar,llposeq = + collect_fix mi (n+1) iarr narr carr pisarr newabsconcl newenv in + Array.append [|nme|] lnme , Array.append [|resrec.princ|] lappel_rec + , (resrec.evarlist@llevar) , (resrec.hypnum@llposeq) let mkevarmap_aux ex = let x,y = ex in (mkevarmap_from_listex x),y @@ -568,9 +571,10 @@ let interp_fonc_tacarg fonctac gl = let invfun_proof fonc def_fonc gl_abstr pis env sigma = let mi = {concl=pis; absconcl=gl_abstr; mimick=def_fonc; env=env; - sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false} in - let princ_proof,levar,lposeq,evararr,absc,parms = proofPrinc mi [] [] [] in - princ_proof,levar,lposeq,evararr,absc,parms + sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false ; + lst_vars = []; lst_eqs = []; lst_recs = []} in + proofPrinc mi + (* Do intros [i] times, then do rewrite on all introduced hyps which are called like [heq_prefix], FIX: have another filter than the name. *) let rec iterintro i = @@ -587,7 +591,7 @@ let rec iterintro i = let sub = try String.sub hypname 0 (String.length heq_prefix) with _ -> "" (* different than [heq_prefix] *) in - if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 "Cannot rewrite") + if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 (str "Cannot rewrite")) )) gl) @@ -647,7 +651,7 @@ let rec applistc_iota cstr lcstr env sigma = | [] -> cstr,[] | arg::lcstr' -> let arghd = - if isApp arg then let x,_ = destApplication arg in x else arg in + if isApp arg then let x,_ = destApp arg in x else arg in if isConstruct arghd (* of the form [(C ...)]*) then applistc_iota (Tacred.nf env sigma (nf_beta (applistc cstr [arg]))) @@ -686,39 +690,38 @@ let invfun c l dorew gl = let pis = add_pis (pf_concl gl) gl listargs' in (* princ_proof builds the principle *) let _ = resetmeta() in - let princ_proof,levar, lposeq,evararr,_,parms = - invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in + let pr = invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in (* Generalize the goal. [[x1:T1][x2:T2]... g[arg1 <- x1 ...]]. *) let gl_abstr' = add_lambdas (pf_concl gl) gl listargs' in (* apply parameters immediately *) let gl_abstr = - applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev parms)) in + applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev pr.params)) in (* we apply args of the fix now, the parameters will be applied later *) let princ_proof_applied_args = - applistc princ_proof (listsuf (List.length parms) listargs') in + applistc pr.princ (listsuf (List.length pr.params) listargs') in (* parameters are still there so patternify must not take them -> lift *) let princ_proof_applied_lift = - lift (List.length levar) princ_proof_applied_args in - let princ_applied_hyps'' = patternify (List.rev levar) + lift (List.length pr.evarlist) princ_proof_applied_args in + let princ_applied_hyps'' = patternify (List.rev pr.evarlist) princ_proof_applied_lift (Name (id_of_string "Hyp")) in (* if there was a fix, we will not add "Q" as in funscheme, so we make a pop, TODO: find were we made the lift in proofPrinc instead and supress it here, and add lift in funscheme. *) let princ_applied_hyps' = - if Array.length evararr > 0 then popn 1 princ_applied_hyps'' + if Array.length pr.mutfixmetas > 0 then popn 1 princ_applied_hyps'' else princ_applied_hyps'' in (* if there is was fix, we have to replace the meta representing the predicate of the goal by the abstracted goal itself. *) let princ_applied_hyps = - if Array.length evararr > 0 then (* mutual Fixpoint not treated in the tactic *) - (substit_red 0 (evararr.(0)) gl_abstr princ_applied_hyps') + if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) + (substit_red 0 (pr.mutfixmetas.(0)) gl_abstr princ_applied_hyps') else princ_applied_hyps' (* No Fixpoint *) in let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in (* Same thing inside levar *) let newlevar' = - if Array.length evararr > 0 then (* mutual Fixpoint not treated in the tactic *) - List.map (fun (x,y) -> x,substit_red 0 (evararr.(0)) gl_abstr y) levar - else levar + if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*) + List.map (fun (x,y) -> x,substit_red 0 (pr.mutfixmetas.(0)) gl_abstr y) pr.evarlist + else pr.evarlist in (* replace params metavar by real args *) let rec replace_parms lparms largs t = @@ -726,19 +729,19 @@ let invfun c l dorew gl = [], _ -> t | ((p,_,_)::lp), (a::la) -> let t'= substitterm 0 p a t in replace_parms lp la t' | _, _ -> error "problem with number of args." in - let princ_proof_applied = replace_parms parms listargs' princ_applied_hyps in + let princ_proof_applied = replace_parms pr.params listargs' princ_applied_hyps in let _ = prNamedLConstr "levar:" (List.map fst newlevar') in let _ = prNamedLConstr "levar types:" (List.map snd newlevar') in let _ = prNamedConstr "princ_proof_applied" princ_proof_applied in (* replace also in levar *) let newlevar = - List.rev (List.map (fun (x,y) -> x, replace_parms parms listargs' y) newlevar') in + List.rev (List.map (fun (x,y) -> x, replace_parms pr.params listargs' y) newlevar') in (* (* replace params metavar by abstracted variables *) - let princ_proof_params = npatternify (List.rev parms) princ_applied_hyps in + let princ_proof_params = npatternify (List.rev pr.params) princ_applied_hyps in (* we apply now the real parameters *) let princ_proof_applied = - applistc princ_proof_params (listpref (List.length parms) listargs') in + applistc princ_proof_params (listpref (List.length pr.params) listargs') in *) let princ_applied_evars = apply_levars princ_proof_applied newlevar in let open_princ_proof_applied = princ_applied_evars in @@ -746,11 +749,11 @@ let invfun c l dorew gl = let _ = prNamedLConstr "evars" (List.map snd (fst princ_applied_evars)) in let listargs_ids = List.map destVar (List.filter isVar listargs') in (* debug: impression du but*) -(* let lgl = Evd.to_list (sig_sig gl) in *) -(* let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in *) -(* let _ = prstr "fin gl \n\n" in *) + let lgl = Evd.to_list (sig_sig gl) in + let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in + let _ = prstr "fin gl \n\n" in invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids - gl dorew lposeq + gl dorew pr.hypnum (* function must be a constant, all arguments must be given. *) let invfun_verif c l dorew gl = @@ -763,11 +766,6 @@ let invfun_verif c l dorew gl = else error "wrong number of arguments for the function" -TACTIC EXTEND FunctionalInduction - [ "Functional" "Induction" constr(c) ne_constr_list(l) ] - -> [ invfun_verif c l true ] -END - (* Construction of the functional scheme. *) @@ -780,13 +778,14 @@ let buildFunscheme fonc mutflist = let pis = prod_change_concl ftyp gl_app in (* Here we call the function invfun_proof, that effectively builds the scheme *) - let princ_proof,levar,_,evararr,absc,parms = - invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in +(* let princ_proof,levar,_,evararr,absc,parms = *) + let _ = prstr "Recherche du principe... lancement de invfun_proof\n" in + let pr = invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in (* parameters are still there (unboud rel), and patternify must not take them -> lift*) - let princ_proof_lift = lift (List.length levar) princ_proof in + let princ_proof_lift = lift (List.length pr.evarlist) pr.princ in let princ_proof_hyps = - patternify (List.rev levar) princ_proof_lift (Name (id_of_string "Hyp")) in + patternify (List.rev pr.evarlist) princ_proof_lift (Name (id_of_string "Hyp")) in let rec princ_replace_metas ev abs i t = if i>= Array.length ev then t else (* fix? *) @@ -802,49 +801,61 @@ let buildFunscheme fonc mutflist = mkLambda (Name (id_of_name nam) , typ, substitterm 0 ev (mkRel 1) (lift 0 acc))) t (List.rev params) in - if Array.length evararr = 0 (* Is there a Fixpoint? *) + if Array.length pr.mutfixmetas = 0 (* Is there a Fixpoint? *) then (* No Fixpoint *) - princ_replace_params parms (mkLambda ((Name (id_of_string "Q")), + princ_replace_params pr.params (mkLambda ((Name (id_of_string "Q")), prod_change_concl ftyp mkthesort, (substitterm 0 gl (mkRel 1) princ_proof_hyps))) else (* there is a fix -> add parameters + replace metas *) - let princ_rpl = princ_replace_metas evararr absc 0 princ_proof_hyps in - princ_replace_params parms princ_rpl + let princ_rpl = + princ_replace_metas pr.mutfixmetas pr.conclarray 0 princ_proof_hyps in + princ_replace_params pr.params princ_rpl (* Declaration of the functional scheme. *) let declareFunScheme f fname mutflist = + let _ = prstr "Recherche du perincipe...\n" in + let id_to_cstr id = + try constr_of_id (Global.env()) id + with + Not_found -> error (string_of_id id ^ " not found in the environment") in let flist = if mutflist=[] then [f] else mutflist in - let fcstrlist = Array.of_list (List.map constr_of flist) in - let scheme = buildFunscheme (constr_of f) fcstrlist in + let fcstrlist = Array.of_list (List.map id_to_cstr flist) in + let idf = id_to_cstr f in + let scheme = buildFunscheme idf fcstrlist in let _ = prstr "Principe:" in let _ = prconstr scheme in let ce = { const_entry_body = scheme; const_entry_type = None; - const_entry_opaque = false } in - let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition)) in + const_entry_opaque = false; + const_entry_boxed = true } in + let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition Scheme)) in () +TACTIC EXTEND functional_induction + [ "old" "functional" "induction" constr(c) ne_constr_list(l) ] + -> [ invfun_verif c l true ] +END + VERNAC COMMAND EXTEND FunctionalScheme - [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" - constr(c) "with" ne_constr_list(l) ] + [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" + ident(c) "with" ne_ident_list(l) ] -> [ declareFunScheme c na l ] -| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" constr(c) ] +| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ] -> [ declareFunScheme c na [] ] END - + (* *** Local Variables: *** *** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" *** -*** tab-width: 1 *** *** tuareg-default-indent:1 *** *** tuareg-begin-indent:1 *** *** tuareg-let-indent:1 *** diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml index a125b9a7..ce775e0b 100644 --- a/contrib/funind/tacinvutils.ml +++ b/contrib/funind/tacinvutils.ml @@ -21,9 +21,9 @@ open Reductionops (*s printing of constr -- debugging *) (* comment this line to see debug msgs *) -let msg x = () ;; let prterm c = str "" +let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ prterm c ++ str"\n") +let prconstr c = msg (str" " ++ pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) @@ -31,7 +31,7 @@ let prchr () = msg (str" (ret) \n") let prNamedConstr s c = begin msg(str ""); - msg(str(s^"==>\n ") ++ prterm c ++ str "\n<==\n"); + msg(str(s^"==>\n ") ++ pr_lconstr c ++ str "\n<==\n"); msg(str ""); end @@ -72,10 +72,11 @@ let rec mkevarmap_from_listex lex = let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in let _ = prstr "OF TYPE: " in let _ = prconstr typ in*) - let info ={ + let info = { evar_concl = typ; - evar_hyps = empty_named_context; - evar_body = Evar_empty} in + evar_hyps = empty_named_context_val; + evar_body = Evar_empty; + evar_extra = None} in Evd.add (mkevarmap_from_listex lex') ex info let mkEq typ c1 c2 = @@ -126,7 +127,7 @@ let apply_leqtrpl_t t leq = let apply_refl_term eq t = - let _,arr = destApplication eq in + let _,arr = destApp eq in let reli= (Array.get arr 1) in let by_t= (Array.get arr 2) in substitterm 0 reli by_t t @@ -144,7 +145,7 @@ let apply_eq_leqtrpl leq eq = let constr_head_match u t= if isApp u then - let uhd,args= destApplication u in + let uhd,args= destApp u in uhd=t else false @@ -187,7 +188,7 @@ let rec buildrefl_from_eqs eqs = match eqs with | [] -> [] | cstr::eqs' -> - let eq,args = destApplication cstr in + let eq,args = destApp cstr in (mkRefl (Array.get args 0) (Array.get args 2)) :: (buildrefl_from_eqs eqs') @@ -237,7 +238,7 @@ let rec substit_red prof t by_t in_u = (* [exchange_reli_arrayi t=(reli x y ...) tarr (d,f)] exchange each reli by tarr.(f-i). *) let exchange_reli_arrayi tarr (d,f) t = - let hd,args= destApplication t in + let hd,args= destApp t in let i = destRel hd in let res = whd_beta (mkApp (tarr.(f-i) ,args)) in res @@ -269,7 +270,7 @@ let def_of_const t = (* nom d'une constante. Must be a constante. x*) let name_of_const t = match (kind_of_term t) with - Const cst -> Names.string_of_label (Names.label cst) + Const cst -> Names.string_of_label (Names.con_label cst) |_ -> assert false ;; diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli index 2fc37b2c..64b21213 100644 --- a/contrib/funind/tacinvutils.mli +++ b/contrib/funind/tacinvutils.mli @@ -71,9 +71,10 @@ val expand_letins: constr -> constr val def_of_const: constr -> constr val name_of_const: constr -> string + (*i - Local Variables: - compile-command: "make -k tacinvutils.cmi" - End: + *** Local Variables: *** + *** compile-command: "make -C ../.. contrib/funind/tacinvutils.cmi" *** + *** End: *** i*) diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index 61d0d5a3..ef1d095e 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -21,7 +21,7 @@ and ct_BINDING = CT_binding of ct_ID_OR_INT * ct_FORMULA and ct_BINDING_LIST = CT_binding_list of ct_BINDING list -and ct_BOOL = +and t_BOOL = CT_false | CT_true and ct_CASE = @@ -46,7 +46,7 @@ and ct_COMMAND = | 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 * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_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 @@ -119,11 +119,13 @@ and ct_COMMAND = | 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 @@ -135,6 +137,7 @@ and ct_COMMAND = | 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 @@ -465,8 +468,8 @@ and ct_MODULE_EXPR = | 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 * ct_FORMULA - | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID * 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 @@ -530,6 +533,7 @@ and ct_RED_COM = | 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 = @@ -637,6 +641,8 @@ and ct_TACTIC_COM = | 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 @@ -665,8 +671,8 @@ and ct_TACTIC_COM = | 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 * ct_USING * ct_INTRO_PATT_OPT - | CT_new_induction of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT + | 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 @@ -679,9 +685,9 @@ and ct_TACTIC_COM = | CT_reflexivity | CT_rename of ct_ID * ct_ID | CT_repeat of ct_TACTIC_COM - | CT_replace_with of ct_FORMULA * ct_FORMULA - | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | 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 diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index d5236a7a..dc27cf98 100755..100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -1,13 +1,11 @@ (* 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 Ctast;; open Termops;; open Nameops;; open Auto;; open Clenv;; open Command;; -open Ctast;; open Declarations;; open Declare;; open Eauto;; @@ -38,7 +36,6 @@ open Typing;; open Util;; open Vernacentries;; open Vernacinterp;; -open Evar_refiner;; let parse_com = Pcoq.parse_string Pcoq.Constr.constr;; @@ -89,13 +86,13 @@ let rec def_const_in_term_rec vl x = | Sort(c) -> c | Ind(ind) -> let (mib, mip) = Global.lookup_inductive ind in - mip.mind_sort + 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 (lookup_constant c vl).const_type + | 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 = @@ -113,7 +110,7 @@ let rec print_info_script sigma osign pf = match pf.ref with | None -> (mt ()) | Some(r,spfl) -> - pr_rule r ++ + Tactic_printer.pr_rule r ++ match spfl with | [] -> (str " " ++ fnl()) @@ -152,8 +149,7 @@ let pp_string x = (***************************************************************************) let unify_e_resolve (c,clenv) gls = - let (wc,kONT) = startWalk gls in - let clenv' = connect_clenv wc clenv in + let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in vernac_e_resolve_constr c gls @@ -179,7 +175,7 @@ and e_my_find_search db_list local_db hdc concl = list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list) in let tac_of_hint = - fun ({pri=b; pat = p; code=t} as patac) -> + fun ({pri=b; pat = p; code=t} as _patac) -> (b, let tac = match t with @@ -189,7 +185,7 @@ and e_my_find_search db_list local_db hdc concl = | 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_constr c + | Unfold_nth c -> unfold_in_concl [[],c] | Extern tacast -> Auto.conclPattern concl (out_some p) tacast in @@ -341,7 +337,7 @@ let e_breadth_search debug n db_list local_db gl = 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 gl in + let local_db = make_local_hint_db [] gl in if n = 0 then e_depth_search debug p db_list local_db gl else @@ -351,17 +347,17 @@ let eauto debug np dbnames = let db_list = List.map (fun x -> - try Stringmap.find x !searchtable + 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 = stringmap_dom !searchtable in + let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in - let local_db = make_local_hint_db gl in + let db_list = List.map searchtable_map dbnames in + let _local_db = make_local_hint_db [] gl in tclTRY (e_search_auto debug n db_list) gl let my_full_eauto n gl = full_eauto false (n,0) gl @@ -369,8 +365,6 @@ let my_full_eauto n gl = full_eauto false (n,0) gl (********************************************************************** copié de tactics/auto.ml on a juste modifié search_gen *) -let searchtable_map name = - Stringmap.find name !searchtable (* 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 @@ -397,7 +391,7 @@ and my_find_search db_list local_db hdc concl = (local_db::db_list) in List.map - (fun ({pri=b; pat=p; code=t} as patac) -> + (fun ({pri=b; pat=p; code=t} as _patac) -> (b, match t with | Res_pf (term,cl) -> unify_resolve (term,cl) @@ -407,7 +401,7 @@ and my_find_search db_list local_db hdc concl = tclTHEN (unify_resolve (term,cl)) (trivial_fail_db db_list local_db) - | Unfold_nth c -> unfold_constr c + | Unfold_nth c -> unfold_in_concl [[],c] | Extern tacast -> conclPattern concl (out_some p) tacast)) tacl @@ -476,7 +470,7 @@ let rec search_gen decomp n db_list local_db extra_sign goal = try [make_apply_entry (pf_env g') (project g') (true,false) - hid (mkVar hid,body_of_type htyp)] + (mkVar hid,body_of_type htyp)] with Failure _ -> [] in (free_try @@ -499,11 +493,11 @@ let search = search_gen 0 let default_search_depth = ref 5 let full_auto n gl = - let dbnames = stringmap_dom !searchtable in + let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in - let db_list = List.map (fun x -> searchtable_map x) dbnames 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 gl) hyps) gl + tclTRY (search n db_list (make_local_hint_db [] gl) hyps) gl let default_full_auto gl = full_auto !default_search_depth gl (************************************************************************) @@ -568,7 +562,7 @@ let blast gls = open_subgoals = 1; goal = g; ref = None } in - try (let (sgl,v) as res = !blast_tactic gls 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 @@ -590,7 +584,7 @@ let blast gls = ;; let blast_tac display_function = function - | (n::_) as l -> + | (n::_) as _l -> (function g -> let exp_ast = (blast g) in (display_function exp_ast; @@ -599,7 +593,7 @@ let blast_tac display_function = function let blast_tac_txt = blast_tac - (function x -> msgnl(Pptactic.pr_glob_tactic (Tacinterp.glob_tactic x)));; + (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));; (* Obsolète ? overwriting_add_tactic "Blast1" blast_tac_txt;; diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli index 21c29bc9..f6701943 100644 --- a/contrib/interface/blast.mli +++ b/contrib/interface/blast.mli @@ -1,5 +1,3 @@ val blast_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - int list -> - Proof_type.goal Tacmach.sigma -> - Proof_type.goal list Proof_type.sigma * Proof_type.validation;; + int list -> Proof_type.tactic diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index 7bf12f3b..730e055b 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -4,7 +4,6 @@ open Names;; open Nameops;; open Util;; -open Ast;; open Term;; open Pp;; open Libnames;; @@ -13,7 +12,6 @@ open Library;; open Vernacinterp;; open Evd;; open Proof_trees;; -open Termast;; open Tacmach;; open Pfedit;; open Proof_type;; @@ -28,7 +26,6 @@ open Vernacinterp;; open Vernac;; open Command;; open Protectedtoplevel;; -open Coqast;; open Line_oriented_parser;; open Xlate;; open Vtp;; @@ -283,15 +280,12 @@ let print_check judg = let value_ct_ast = (try translate_constr false (Global.env()) value with UserError(f,str) -> - raise(UserError(f, - Ast.print_ast - (ast_of_constr true (Global.env()) value) ++ + 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, Ast.print_ast (ast_of_constr true (Global.env()) - value) ++ fnl() ++ str))) in + raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in ((ctf_SearchResults !global_request_id), (Some (P_pl (CT_premises_list @@ -315,18 +309,6 @@ and ntyp = nf_betaiota typ in -(* The following function is copied from globpr in env/printer.ml *) -let globcv x = - match x with - | Node(_,"MUTIND", (Path(_,sp))::(Num(_,tyi))::_) -> - convert_qualid - (Nametab.shortest_qualid_of_global Idset.empty (IndRef(sp,tyi))) - | Node(_,"MUTCONSTRUCT",(Path(_,sp))::(Num(_,tyi))::(Num(_,i))::_) -> - convert_qualid - (Nametab.shortest_qualid_of_global Idset.empty - (ConstructRef ((sp, tyi), i))) - | _ -> failwith "globcv : unexpected value";; - let pbp_tac_pcoq = pbp_tac (function (x:raw_tactic_expr) -> output_results @@ -360,12 +342,13 @@ let debug_tac2_pcoq tac = 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 + let _result = report_error tac the_goal the_ast the_path [] g in (errorlabstrm "DEBUG TACTIC" - (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++ + (str "no error here " ++ fnl () ++ Printer.pr_goal (sig_it g) ++ fnl () ++ str "the tactic is" ++ fnl () ++ - Pptactic.pr_glob_tactic tac); - result) + 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 @@ -413,11 +396,11 @@ let inspect n = let (_, _, v) = get_variable (basename sp) in add_search2 (Nametab.locate (qualid_of_sp sp)) v | (sp,kn), "CONSTANT" -> - let {const_type=typ} = Global.lookup_constant kn in + 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.understand Evd.empty (Global.env()) + (Pretyping.Default.understand Evd.empty (Global.env()) (RRef(dummy_loc, IndRef(kn,0)))) | _ -> failwith ("unexpected value 1 for "^ (string_of_id (basename (fst oname))))) @@ -571,11 +554,11 @@ let pcoq_search s l = (* 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 + let _c1 = strip_outer_cast c in match kind_of_term c with | Prod(_, hyp, c2) -> (try -(* let _ = msgnl ((str "WHOLE ") ++ (Printer.prterm c)) in +(* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *) if Matching.is_matching pat hyp then (msgnl (str "ok"); true) @@ -616,7 +599,7 @@ let pcoq_show_goal = function | Some n -> show_nth n | None -> if !pcoq_started = Some true (* = debug *) then - msg (Pfedit.pr_open_subgoals ()) + msg (Printer.pr_open_subgoals ()) else errorlabstrm "show_goal" (str "Show must be followed by an integer in Centaur mode");; @@ -632,17 +615,17 @@ let pcoq_hook = { } -TACTIC EXTEND Pbp -| [ "Pbp" ident_opt(idopt) natural_list(nl) ] -> +TACTIC EXTEND pbp +| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> [ if_pcoq pbp_tac_pcoq idopt nl ] END -TACTIC EXTEND CtDebugTac -| [ "DebugTac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] +TACTIC EXTEND ct_debugtac +| [ "debugtac" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] END -TACTIC EXTEND CtDebugTac2 -| [ "DebugTac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] +TACTIC EXTEND ct_debugtac2 +| [ "debugtac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] END diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml deleted file mode 100644 index 67279bb8..00000000 --- a/contrib/interface/ctast.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* A copy of pre V7 ast *) - -open Names -open Libnames - -type loc = Util.loc - -type t = - | Node of loc * string * t list - | Nvar of loc * string - | Slam of loc * string option * t - | Num of loc * int - | Id of loc * string - | Str of loc * string - | Path of loc * string list - | Dynamic of loc * Dyn.t - -let section_path sl = - match List.rev sl with - | s::pa -> - Libnames.encode_kn - (make_dirpath (List.map id_of_string pa)) - (id_of_string s) - | [] -> invalid_arg "section_path" - -let is_meta s = String.length s > 0 && s.[0] == '$' - -let purge_str s = - if String.length s == 0 || s.[0] <> '$' then s - else String.sub s 1 (String.length s - 1) - -let rec ct_to_ast = function - | Node (loc,a,b) -> Coqast.Node (loc,a,List.map ct_to_ast b) - | Nvar (loc,a) -> - if is_meta a then Coqast.Nmeta (loc,purge_str a) - else Coqast.Nvar (loc,id_of_string a) - | Slam (loc,Some a,b) -> - if is_meta a then Coqast.Smetalam (loc,purge_str a,ct_to_ast b) - else Coqast.Slam (loc,Some (id_of_string a),ct_to_ast b) - | Slam (loc,None,b) -> Coqast.Slam (loc,None,ct_to_ast b) - | Num (loc,a) -> Coqast.Num (loc,a) - | Id (loc,a) -> Coqast.Id (loc,a) - | Str (loc,a) -> Coqast.Str (loc,a) - | Path (loc,sl) -> Coqast.Path (loc,section_path sl) - | Dynamic (loc,a) -> Coqast.Dynamic (loc,a) - -let rec ast_to_ct = function x -> failwith "ast_to_ct: not TODO?" -(* - | Coqast.Node (loc,a,b) -> Node (loc,a,List.map ast_to_ct b) - | Coqast.Nvar (loc,a) -> Nvar (loc,string_of_id a) - | Coqast.Nmeta (loc,a) -> Nvar (loc,"$"^a) - | Coqast.Slam (loc,Some a,b) -> - Slam (loc,Some (string_of_id a),ast_to_ct b) - | Coqast.Slam (loc,None,b) -> Slam (loc,None,ast_to_ct b) - | Coqast.Smetalam (loc,a,b) -> Slam (loc,Some ("$"^a),ast_to_ct b) - | Coqast.Num (loc,a) -> Num (loc,a) - | Coqast.Id (loc,a) -> Id (loc,a) - | Coqast.Str (loc,a) -> Str (loc,a) - | Coqast.Path (loc,a) -> - let (sl,bn) = Libnames.decode_kn a in - Path(loc, (List.map string_of_id - (List.rev (repr_dirpath sl))) @ [string_of_id bn]) - | Coqast.Dynamic (loc,a) -> Dynamic (loc,a) -*) - -let loc = function - | Node (loc,_,_) -> loc - | Nvar (loc,_) -> loc - | Slam (loc,_,_) -> loc - | Num (loc,_) -> loc - | Id (loc,_) -> loc - | Str (loc,_) -> loc - | Path (loc,_) -> loc - | Dynamic (loc,_) -> loc - -let str s = Str(Util.dummy_loc,s) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index ec989296..8096bc31 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -73,7 +73,7 @@ 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 (map_subst env) (fun _ x -> x) subst x;; + | 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]) -> @@ -251,7 +251,7 @@ let rec sort_list = function 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 ((*Ctast.ct_to_ast*) ast,NoBindings) in + let cb = in_gen rawwit_constr_with_bindings (ast,NoBindings) in TacExtend (zz,"Rewrite",[b;cb]) open Vernacexpr diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 index bf596b28..890bb3ce 100644 --- a/contrib/interface/debug_tac.ml4 +++ b/contrib/interface/debug_tac.ml4 @@ -1,7 +1,5 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -open Ast;; -open Coqast;; open Tacmach;; open Tacticals;; open Proof_trees;; @@ -12,6 +10,8 @@ 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 = @@ -72,11 +72,6 @@ let check_subgoals_count2 Recursive_fail (List.hd !new_report_holder))); result;; -(* -let traceable = function - Node(_, "TACTICLIST", a::b::tl) -> true - | _ -> false;; -*) let traceable = function | TacThen _ | TacThens _ -> true | _ -> false;; @@ -116,25 +111,6 @@ let count_subgoals2 result;; let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function -(* - Node(_, "TACTICLIST", [a;Node(_, "TACLIST", l)]) -> - (fun report_holder -> checked_thens report_holder a l) - | Node(_, "TACTICLIST", a::((Node(_, "TACLIST", l))as b)::c::tl) -> - local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl)) - | Node(_, "TACTICLIST", [a;b]) -> - (fun report_holder -> checked_then report_holder a b) - | Node(_, "TACTICLIST", a::b::c::tl) -> - local_interp(ope ("TACTICLIST", (ope("TACTICLIST", [a;b]))::c::tl)) - | ast -> - (fun report_holder g -> - try - let (gls, _) as result = Tacinterp.interp ast 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)) -*) TacThens (a,l) -> (fun report_holder -> checked_thens report_holder a l) | TacThen (a,b) -> @@ -263,9 +239,14 @@ and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tacti 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_tactic t1 in - let t2 = out_gen wit_tactic t2 in + 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 -> @@ -276,78 +257,18 @@ let on_then = function [t1;t2;l] -> | _ -> anomaly "bad arguments for on_then";; let mkOnThen t1 t2 selected_indices = - let a = in_gen rawwit_tactic t1 in - let b = in_gen rawwit_tactic t2 in + 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 -> (Num((0,0),n))::select_success (n+1) tl - | _::tl -> select_success (n+1) tl;; -*) let rec select_success n = function [] -> [] | Report_node(true,_,_)::tl -> n::select_success (n+1) tl | _::tl -> select_success (n+1) tl;; -(* -let rec expand_tactic = function - Node(loc1, "TACTICLIST", [a;Node(loc2,"TACLIST", l)]) -> - Node(loc1, "TACTICLIST", - [expand_tactic a; - Node(loc2, "TACLIST", List.map expand_tactic l)]) - | Node(loc1, "TACTICLIST", a::((Node(loc2, "TACLIST", l))as b)::c::tl) -> - expand_tactic (Node(loc1, "TACTICLIST", - (Node(loc1, "TACTICLIST", [a;b]))::c::tl)) - | Node(loc1, "TACTICLIST", [a;b]) -> - Node(loc1, "TACTICLIST",[expand_tactic a;expand_tactic b]) - | Node(loc1, "TACTICLIST", a::b::c::tl) -> - expand_tactic (Node(loc1, "TACTICLIST", - (Node(loc1, "TACTICLIST", [a;b]))::c::tl)) - | any -> any;; -*) -(* Useless: already in binary form... -let rec expand_tactic = function - TacThens (a,l) -> TacThens (expand_tactic a, List.map expand_tactic l) - | TacThen (a,b) -> TacThen (expand_tactic a, expand_tactic b) - | any -> any;; -*) - -(* -let rec reconstruct_success_tac ast = - match ast with - Node(_, "TACTICLIST", [a;Node(_,"TACLIST",l)]) -> - (function - Report_node(true, n, l) -> ast - | Report_node(false, n, rl) -> - ope("TACTICLIST",[a;ope("TACLIST", - List.map2 reconstruct_success_tac l rl)]) - | Failed n -> ope("Idtac",[]) - | Tree_fail r -> reconstruct_success_tac a r - | Mismatch (n,p) -> a) - | Node(_, "TACTICLIST", [a;b]) -> - (function - Report_node(true, n, l) -> ast - | Report_node(false, n, rl) -> - let selected_indices = select_success 1 rl in - ope("OnThen", a::b::selected_indices) - | Failed n -> ope("Idtac",[]) - | 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) -> ast - | Failed n -> ope("Idtac",[]) - | _ -> - errorlabstrm - "this error case should not happen on an unknown tactic" - (str "error in reconstruction with " ++ fnl () ++ - (gentacpr ast)));; -*) let rec reconstruct_success_tac (tac:glob_tactic_expr) = match tac with TacThens (a,l) -> @@ -355,7 +276,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = Report_node(true, n, l) -> tac | Report_node(false, n, rl) -> TacThens (a,List.map2 reconstruct_success_tac l rl) - | Failed n -> TacId "" + | Failed n -> TacId [] | Tree_fail r -> reconstruct_success_tac a r | Mismatch (n,p) -> a) | TacThen (a,b) -> @@ -364,16 +285,16 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = | Report_node(false, n, rl) -> let selected_indices = select_success 1 rl in TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", - [in_gen globwit_tactic a; - in_gen globwit_tactic b; + [in_gen globwit_main_tactic a; + in_gen globwit_main_tactic b; in_gen (wit_list0 globwit_int) selected_indices])) - | Failed n -> TacId "" + | 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 "" + | Failed n -> TacId [] | _ -> errorlabstrm "this error case should not happen on an unknown tactic" @@ -391,21 +312,6 @@ let rec path_to_first_error = function p::(path_to_first_error t) | _ -> [];; -(* -let rec flatten_then_list tail = function - | Node(_, "TACTICLIST", [a;b]) -> - flatten_then_list ((flatten_then b)::tail) a - | ast -> ast::tail -and flatten_then = function - Node(_, "TACTICLIST", [a;b]) -> - ope("TACTICLIST", flatten_then_list [flatten_then b] a) - | Node(_, "TACLIST", l) -> - ope("TACLIST", List.map flatten_then l) - | Node(_, "OnThen", t1::t2::l) -> - ope("OnThen", (flatten_then t1)::(flatten_then t2)::l) - | ast -> ast;; -*) - let debug_tac = function [(Tacexp ast)] -> (fun g -> @@ -430,26 +336,8 @@ let debug_tac = function add_tactic "DebugTac" debug_tac;; *) -(* -hide_tactic "OnThen" on_then;; -*) -Refiner.add_tactic "OnThen" on_then;; +Tacinterp.add_tactic "OnThen" on_then;; -(* -let rec clean_path p ast l = - match ast, l with - Node(_, "TACTICLIST", ([_;_] as tacs)), fst::tl -> - fst::(clean_path 0 (List.nth tacs (fst - 1)) tl) - | Node(_, "TACTICLIST", tacs), 2::tl -> - let rank = (List.length tacs) - p in - rank::(clean_path 0 (List.nth tacs (rank - 1)) tl) - | Node(_, "TACTICLIST", tacs), 1::tl -> - clean_path (p+1) ast tl - | Node(_, "TACLIST", tacs), fst::tl -> - fst::(clean_path 0 (List.nth tacs (fst - 1)) tl) - | _, [] -> [] - | _, _ -> failwith "this case should not happen in clean_path";; -*) let rec clean_path tac l = match tac, l with | TacThen (a,b), fst::tl -> @@ -554,8 +442,8 @@ let descr_first_error tac = (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ fnl () ++ Cerrors.explain_exn e ++ fnl () ++ fnl () ++ str "on goal" ++ fnl () ++ - pr_goal (sig_it (strip_some !the_goal)) ++ fnl () ++ - str "faulty tactic is" ++ fnl () ++ 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)) diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli index ded714b6..da4bbaa0 100644 --- a/contrib/interface/debug_tac.mli +++ b/contrib/interface/debug_tac.mli @@ -1,6 +1,6 @@ val report_error : Tacexpr.glob_tactic_expr -> - Proof_type.goal Proof_type.sigma option ref -> + 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/line_parser.ml4 b/contrib/interface/line_parser.ml4 index b5669351..0b13a092 100755 --- a/contrib/interface/line_parser.ml4 +++ b/contrib/interface/line_parser.ml4 @@ -84,7 +84,7 @@ let rec string len = parser spaces and tabulations are ignored, identifiers, integers, strings, opening and closing square brackets. Lexical errors are ignored ! *) -let rec next_token = parser count +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 @@ -96,7 +96,7 @@ let rec next_token = parser count (* A very simple lexical analyser to recognize a integer value behind blank characters *) -let rec next_int = parser count +let rec next_int = parser _count [< '' ' | '\t'; v = next_int >] -> v | [< ''0'..'9' as c; i = (parse_int (get_digit c))>] -> (match i with diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index eaff0968..9a503cfb 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -2,9 +2,6 @@ open Sign;; open Classops;; open Names;; open Nameops -open Coqast;; -open Ast;; -open Termast;; open Term;; open Impargs;; open Reduction;; @@ -90,13 +87,6 @@ let implicit_args_to_ast_list sp mipv = [] -> [] | _ -> [VernacComments (List.rev implicit_args_descriptions)];; -let convert_qualid qid = - let d, id = Libnames.repr_qualid qid in - match repr_dirpath d with - [] -> nvar id - | d -> ope("QUALID", List.fold_left (fun l s -> (nvar s)::l) - [nvar id] d);; - (* This function converts constructors for an inductive definition to a Coqast.t. It is obtained directly from print_constructors in pretty.ml *) @@ -117,10 +107,10 @@ let convert_one_inductive sp tyi = let env = Global.env () in let envpar = push_rel_context params env in let sp = sp_of_global (IndRef (sp, tyi)) in - ((dummy_loc,basename sp), None, + (((dummy_loc,basename sp), convert_env(List.rev params), (extern_constr true envpar arity), - convert_constructors envpar cstrnames cstrtypes);; + 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 @@ -142,16 +132,6 @@ let implicits_to_ast_list implicits = | None -> [] | Some s -> [VernacComments [CommentString s]];; -(* -let make_variable_ast name typ implicits = - (ope("VARIABLE", - [string "VARIABLE"; - ope("BINDERLIST", - [ope("BINDER", - [(constr_to_ast (body_of_type typ)); - nvar name])])]))::(implicits_to_ast_list implicits) - ;; -*) let make_variable_ast name typ implicits = (VernacAssumption ((Local,Definitional), @@ -160,7 +140,7 @@ let make_variable_ast name typ implicits = let make_definition_ast name c typ implicits = - VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None, + VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None, (constr_to_ast c), Some (constr_to_ast (body_of_type typ))), (fun _ _ -> ())) ::(implicits_to_ast_list implicits);; @@ -169,13 +149,13 @@ let make_definition_ast name c typ implicits = let constant_to_ast_list kn = let cb = Global.lookup_constant kn in let c = cb.const_body in - let typ = cb.const_type 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 (label kn)) typ l + make_variable_ast (id_of_label (con_label kn)) typ l | Some c1 -> - make_definition_ast (id_of_label (label kn)) (Declarations.force c1) typ l) + make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) let variable_to_ast_list sp = let (id, c, v) = get_variable sp in @@ -198,7 +178,7 @@ 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 kn + | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) | "INDUCTIVE" -> inductive_to_ast_list kn | s -> errorlabstrm @@ -240,7 +220,7 @@ let name_to_ast ref = | Some c1 -> make_definition_ast name c1 typ []) with Not_found -> try - let sp = Nametab.locate_syntactic_definition qid in + let _sp = Nametab.locate_syntactic_definition qid in errorlabstrm "print" (str "printing of syntax definitions not implemented") with Not_found -> diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli index 0eca0a1e..b8c2d7dc 100644 --- a/contrib/interface/name_to_ast.mli +++ b/contrib/interface/name_to_ast.mli @@ -1,2 +1 @@ val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; -val convert_qualid : Libnames.qualid -> Coqast.t;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 3f0b2d2e..8cca7614 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -48,55 +48,8 @@ let ctf_FileErrorMessage reqid pps = int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; -(* -(*In the code for CoqV6.2, the require_module call is encapsulated in - a function "without_mes_ambig". Here I have supposed that this - function has no effect on parsing *) -let try_require_module import specif names = - try Library.require_module - (if specif = "UNSPECIFIED" then None - else Some (specif = "SPECIFICATION")) - (List.map - (fun name -> - (dummy_loc,Libnames.make_short_qualid (Names.id_of_string name))) - names) - (import = "IMPORT") - with - | e -> msgnl (str "Reinterning of " ++ prlist str names ++ str " failed");; -*) -(* -let try_require_module_from_file import specif name fname = - try Library.require_module_from_file (if specif = "UNSPECIFIED" then None - else Some (specif = "SPECIFICATION")) (Some (Names.id_of_string name)) fname (import = "IMPORT") - with - | e -> msgnl (str "Reinterning of " ++ str name ++ str " failed");; -*) -(* -let execute_when_necessary ast = - (match ast with - | Node (_, "GRAMMAR", ((Nvar (_, s)) :: ((Node (_, "ASTLIST", al)) :: []))) -> - Metasyntax.add_grammar_obj s (List.map Ctast.ct_to_ast al) -(* Obsolete - | Node (_, "TOKEN", ((Str (_, s)) :: [])) -> Metasyntax.add_token_obj s -*) - | Node (_, "Require", - ((Str (_, import)) :: - ((Str (_, specif)) :: l))) -> - let mnames = List.map (function - | (Nvar (_, m)) -> m - | _ -> error "parse_string_action : bad require expression") l in - try_require_module import specif mnames - | Node (_, "RequireFrom", - ((Str (_, import)) :: - ((Str (_, specif)) :: - ((Nvar (_, mname)) :: ((Str (_, file_name)) :: []))))) -> - try_require_module_from_file import specif mname file_name - | _ -> ()); ast;; -*) - let execute_when_necessary v = (match v with - | VernacGrammar _ -> Vernacentries.interp v | VernacOpenCloseScope sc -> Vernacentries.interp v | VernacRequire (_,_,l) -> (try @@ -202,12 +155,6 @@ let parse_command_list reqid stream string_list = discard_to_dot stream; msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ int (Stream.count stream)); -(* - Some( Node(l, "PARSING_ERROR", - List.map Ctast.str - (get_substring_list string_list this_pos - (Stream.count stream)))) -*) ParseError ("PARSING_ERROR", get_substring_list string_list this_pos (Stream.count stream)) @@ -216,27 +163,14 @@ let parse_command_list reqid stream string_list = | e-> begin discard_to_dot stream; -(* - Some(Node((0,0), "PARSING_ERROR2", - List.map Ctast.str - (get_substring_list string_list this_pos - (Stream.count 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 + let _ast0 = (execute_when_necessary ast) in (try xlate_vernac ast with e -> -(* - xlate_vernac - (Node((0,0), "PARSING_ERROR2", - List.map Ctast.str - (get_substring_list string_list this_pos - (Stream.count stream)))))::parse_whole_stream() -*) make_parse_error_item "PARSING_ERROR2" (get_substring_list string_list this_pos (Stream.count stream)))::parse_whole_stream() @@ -311,7 +245,7 @@ let parse_file_action reqid file_name = 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 _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 @@ -345,7 +279,7 @@ let parse_file_action reqid file_name = with | ParseOK (Some (_,ast)) -> - let ast0=(execute_when_necessary ast) in + let _ast0=(execute_when_necessary ast) in let term = (try xlate_vernac ast with e -> @@ -381,27 +315,27 @@ let parse_file_action reqid file_name = fnl () ++ Cerrors.explain_exn e));; let add_rec_path_action reqid string_arg ident_arg = - let directory_name = glob string_arg in + 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 = glob string_arg in + 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,v 1.22 2004/04/21 08:36:58 barras Exp $");; + msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");; 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 - read_library (dummy_loc,qid); + require_library [dummy_loc,qid] None; msg (str "opening... "); Declaremods.import_module false (Nametab.locate_module qid); msgnl (str "done" ++ fnl ()); @@ -456,7 +390,6 @@ Libobject.relax true; coqdir [ "contrib"; "interface"; "vernacrc"] in try (Gramext.warning_verbose := false; - Esyntax.warning_verbose := false; coqparser_loop (open_in vernacrc)) with | End_of_file -> () @@ -470,7 +403,7 @@ Libobject.relax true; (try let user_vernacrc = try Some(Sys.getenv "USERVERNACRC") with - | Not_found as e -> + | Not_found -> msgnl (str "no .vernacrc file"); None in (match user_vernacrc with Some f -> coqparser_loop (open_in f) diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index e0f88ba6..d2f71bfc 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -34,13 +34,13 @@ let get_hyp_by_name g name = let evd = project g in let env = pf_env g in try (let judgment = - Pretyping.understand_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_reference c))) + ("cste",type_of (Global.env()) Evd.empty (constr_of_global c))) ;; type pbp_atom = @@ -106,7 +106,7 @@ 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) -> + (a,c,cf,o, Cast(f,_,_), p, func) -> Some(func a c cf o (kind_of_term f) p) | _ -> None;; @@ -154,7 +154,7 @@ let make_pbp_pattern x = [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] let rec make_then = function - | [] -> TacId "" + | [] -> TacId [] | [t] -> t | t1::t2::l -> make_then (TacThen (t1,t2)::l) @@ -177,7 +177,7 @@ let make_pbp_atomic_tactic = function TacAtom (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None)) | PbpTryClear l -> - TacTry (TacAtom (zz, TacClear (List.map (fun s -> AI (zz,s)) l))) + TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));; let rec make_pbp_tactic = function @@ -203,7 +203,7 @@ let (imply_elim1: pbp_rule) = function 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 + let _str_h' = (string_of_id h') in Some(PbpThens ([PbpLApply h], [chain_tactics [make_named_intro h'] (make_clears (h::clear_names)); diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli index 43ec1274..9daba184 100644 --- a/contrib/interface/pbp.mli +++ b/contrib/interface/pbp.mli @@ -1,4 +1,2 @@ val pbp_tac : (Tacexpr.raw_tactic_expr -> 'a) -> - Names.identifier option -> int list -> - Proof_type.goal Tacmach.sigma -> - Proof_type.goal list Proof_type.sigma * Proof_type.validation;; + Names.identifier option -> int list -> Proof_type.tactic diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 5b265ec8..4bec7350 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -11,7 +11,6 @@ open Term open Termops open Util open Proof_type -open Coqast open Pfedit open Translate open Term @@ -54,7 +53,7 @@ and ngoal= {newhyp : nhyp list; t_concl : Term.constr; t_full_concl: Term.constr; - t_full_env: Sign.named_context} + t_full_env: Environ.named_context_val} and ntree= {t_info:string; t_goal:ngoal; @@ -151,42 +150,22 @@ let seq_to_lnhyp sign sign' cl = {newhyp=nh; t_concl=cl; t_full_concl=long_type_hyp !lh cl; - t_full_env = sign@sign'} + t_full_env = Environ.val_of_named_context (sign@sign')} ;; let rule_is_complex r = match r with - Tactic (TacArg (Tacexp t),_) -> true - | Tactic (TacAtom (_,TacAuto _), _) -> true - | Tactic (TacAtom (_,TacSymmetry _), _) -> true + Nested (Tactic + ((TacArg (Tacexp _) + |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true |_ -> false ;; -let ast_of_constr = Termast.ast_of_constr true (Global.env()) ;; - -(* -let rule_to_ntactic r = - let rast = - (match r with - Tactic (s,l) -> - Ast.ope (s,(List.map ast_of_cvt_arg l)) - | Prim (Refine h) -> - Ast.ope ("Exact", - [Node ((0,0), "COMMAND", [ast_of_constr h])]) - | _ -> Ast.ope ("Intros",[])) in - if rule_is_complex r - then (match rast with - Node(_,_,[Node(_,_,[Node(_,_,x)])]) ->x - | _ -> assert false) - - else [rast ] -;; -*) let rule_to_ntactic r = let rt = (match r with - Tactic (t,_) -> t + Nested(Tactic (t,_),_) -> t | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in if rule_is_complex r @@ -197,14 +176,6 @@ let rule_to_ntactic r = else rt ;; -(* -let term_of_command x = - match x with - Node(_,_,y::_) -> y - | _ -> x -;; -*) - (* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt *) @@ -226,7 +197,7 @@ let fill_unproved nt l = let new_sign osign sign = let res=ref [] in List.iter (fun (id,c,ty) -> - try (let (_,_,ty1)= (lookup_named id osign) in + try (let (_,_,_ty1)= (lookup_named id osign) in ()) with Not_found -> res:=(id,c,ty)::(!res)) sign; @@ -247,6 +218,7 @@ let old_sign osign sign = 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 @@ -262,17 +234,17 @@ let to_nproof sigma osign pf = (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) spfl) in (match r with - 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)) + 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); @@ -417,13 +389,6 @@ let enumerate f ln = let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; -(* -let sp_tac tac = - try spt (constr_of_ast (term_of_command tac)) - with _ -> (* let Node(_,t,_) = tac in *) - spe (* sps ("error in sp_tac " ^ t) *) -;; -*) let sp_tac tac = failwith "TODO" let soit_A_une_proposition nh ln t= match !natural_language with @@ -754,13 +719,13 @@ let rec nsortrec vl x = | Sort(c) -> c | Ind(ind) -> let (mib,mip) = lookup_mind_specif vl ind in - mip.mind_sort + 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 (lookup_constant c vl).const_type + | 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 = @@ -791,7 +756,7 @@ let rec group_lhyp lh = 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 + 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 @@ -963,16 +928,6 @@ let natural_lhyp lh hi = Analyse des tactiques. *) -(* -let name_tactic tac = - match tac with - (Node(_,"Interp", - (Node(_,_, - (Node(_,t,_))::_))::_))::_ -> t - |(Node(_,t,_))::_ -> t - | _ -> assert false -;; -*) let name_tactic = function | TacIntroPattern _ -> "Intro" | TacAssumption -> "Assumption" @@ -991,51 +946,8 @@ let arg1_tactic tac = ;; *) -let arg1_tactic tac = failwith "TODO" - -let arg2_tactic tac = - match tac with - (Node(_,"Interp", - (Node(_,_, - (Node(_,_,_::x::_))::_))::_))::_ -> x - | (Node(_,_,_::x::_))::_ -> x - | _ -> assert false -;; - -(* -type nat_tactic = - Split of (Coqast.t list) - | Generalize of (Coqast.t list) - | Reduce of string*(Coqast.t list) - | Other of string*(Coqast.t list) -;; - -let analyse_tac tac = - match tac with - [Node (_, "Split", [Node (_, "BINDINGS", [])])] - -> Split [] - | [Node (_, "Split",[Node(_, "BINDINGS",[Node(_, "BINDING", - [Node (_, "COMMAND", x)])])])] - -> Split x - | [Node (_, "Generalize", [Node (_, "COMMAND", x)])] - ->Generalize x - | [Node (_, "Reduce", [Node (_, "REDEXP", [Node (_, mode, _)]); - Node (_, "CLAUSE", lhyp)])] - -> Reduce(mode,lhyp) - | [Node (_, x,la)] -> Other (x,la) - | _ -> assert false -;; -*) - - - +let arg1_tactic tac = failwith "TODO";; - -let id_of_command x = - match x with - Node(_,_,Node(_,_,y::_)::_) -> y - |_ -> assert false -;; type type_info_subgoals = {ihsg: type_info_subgoals_hyp; isgintro : string} @@ -1285,7 +1197,7 @@ let rec natural_ntree ig ntree = | TacAssumption -> natural_trivial ig lh g gs ltree | TacClear _ -> natural_clear ig lh g gs ltree (* Besoin de l'argument de la tactique *) - | TacSimpleInduction (NamedHyp id,_) -> + | TacSimpleInduction (NamedHyp id) -> natural_induction ig lh g gs ge id ltree false | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in @@ -1294,7 +1206,7 @@ let rec natural_ntree ig ntree = | TacExact c -> natural_exact ig lh g gs c ltree | TacCut c -> natural_cut ig lh g gs c ltree | TacExtend (_,"CutIntro",[a]) -> - let c = out_gen wit_constr a in + 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 c ltree false | TacExtend (_,"CaseIntro",[a]) -> @@ -1518,7 +1430,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = if with_intros then (arity_of_constr_of_mind env indf 1) else 0 in - let ici= 1 in + let _ici= 1 in sph[ (natural_ntree {ihsg= (match (nsort targ1) with @@ -1547,7 +1459,7 @@ and prod_list_var t = 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 _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) @@ -1556,7 +1468,7 @@ 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 = mip.mind_nparams 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 @@ -1586,8 +1498,8 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= 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 _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 ""); @@ -1630,11 +1542,11 @@ and natural_induction ig lh g gs ge arg2 ltree with_intros= 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 _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 _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 *) @@ -1719,8 +1631,8 @@ and natural_reduce ig lh g gs ge mode la ltree = 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 + let _env= (gLOB ge) in + let arg1= (*dbize _env*) arg in spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1740,9 +1652,9 @@ and natural_split ig lh g gs ge la ltree = and natural_generalize ig lh g gs ge la ltree = match la with [arg] -> - let env= (gLOB ge) in + 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 (Global.env()) Evd.empty arg in (* let type_arg=type_of_ast ge arg in*) spv [ (natural_lhyp lh ig.ihsg); diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli index ee269458..9b6787b7 100755 --- a/contrib/interface/showproof.mli +++ b/contrib/interface/showproof.mli @@ -4,9 +4,7 @@ open Names open Term open Util open Proof_type -open Coqast open Pfedit -open Translate open Term open Reduction open Clenv diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml index ee901c5e..dd7f455d 100644 --- a/contrib/interface/showproof_ct.ml +++ b/contrib/interface/showproof_ct.ml @@ -3,7 +3,6 @@ Vers Ctcoq *) -open Esyntax open Metasyntax open Printer open Pp @@ -131,12 +130,12 @@ let rec sp_print x = | "\n" -> fnl () | "Retour chariot pour Show proof" -> fnl () |_ -> str s) - | CT_text_formula f -> prterm (Hashtbl.find ct_FORMULA_constr f) + | 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 + 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 @@ -149,7 +148,7 @@ let rec sp_print x = 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 + 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 @@ -159,7 +158,7 @@ let rec sp_print x = 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 + 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 diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml index e63baecf..6e4782be 100644 --- a/contrib/interface/translate.ml +++ b/contrib/interface/translate.ml @@ -1,13 +1,11 @@ open Names;; open Sign;; open Util;; -open Ast;; open Term;; open Pp;; open Libobject;; open Library;; open Vernacinterp;; -open Termast;; open Tacmach;; open Pfedit;; open Parsing;; @@ -15,97 +13,11 @@ open Evd;; open Evarutil;; open Xlate;; -open Ctast;; open Vtp;; open Ascent;; open Environ;; open Proof_type;; -(* dead code: let rel_reference gt k oper = - if is_existential_oper oper then ope("XTRA", [str "ISEVAR"]) - else begin - let id = id_of_global oper in - let oper', _ = global_operator (Nametab.sp_of_id k id) id in - if oper = oper' then nvar (string_of_id id) - else failwith "xlate" -end;; -*) - -(* dead code: -let relativize relfun = - let rec relrec = - function - | Nvar (_, id) -> nvar id - | Slam (l, na, ast) -> Slam (l, na, relrec ast) - | Node (loc, nna, l) as ast -> begin - try relfun ast - with - | Failure _ -> Node (loc, nna, List.map relrec l) - end - | a -> a in - relrec;; -*) - -(* dead code: -let dbize_sp = - function - | Path (loc, sl, s) -> begin - try section_path sl s - with - | Invalid_argument _ | Failure _ -> - anomaly_loc - (loc, "Translate.dbize_sp (taken from Astterm)", - [< str "malformed section-path" >]) - end - | ast -> - anomaly_loc - (Ast.loc ast, "Translate.dbize_sp (taken from Astterm)", - [< str "not a section-path" >]);; -*) - -(* dead code: -let relativize_cci gt = relativize (function - | Node (_, "CONST", (p :: _)) as gt -> - rel_reference gt CCI (Const (dbize_sp p)) - | Node (_, "MUTIND", (p :: ((Num (_, tyi)) :: _))) as gt -> - rel_reference gt CCI (MutInd (dbize_sp p, tyi)) - | Node (_, "MUTCONSTRUCT", (p :: ((Num (_, tyi)) :: ((Num (_, i)) :: _)))) as gt -> - rel_reference gt CCI (MutConstruct ( - (dbize_sp p, tyi), i)) - | _ -> failwith "caught") gt;; -*) - -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 rec nth_tl l n = if n = 0 then l - else (match l with - | a :: b -> nth_tl b (n - 1) - | [] -> failwith "list too short for nth_tl");; - -let rec discard_coercions = - function - | Slam (l, na, ast) -> Slam (l, na, discard_coercions ast) - | Node (l, ("APPLIST" as nna), (f :: args as all_sons)) -> - (match coercion_description f with - | Some n -> - let new_args = - try nth_tl args n - with - | Failure "list too short for nth_tl" -> [] in - (match new_args with - | a :: (b :: c) -> Node (l, nna, List.map discard_coercions new_args) - | a :: [] -> discard_coercions a - | [] -> Node (l, nna, List.map discard_coercions all_sons)) - | None -> Node (l, nna, List.map discard_coercions all_sons)) - | Node (l, nna, all_sons) -> - Node (l, nna, List.map discard_coercions all_sons) - | it -> it;; - (*translates a formula into a centaur-tree --> FORMULA *) let translate_constr at_top env c = xlate_formula (Constrextern.extern_constr at_top env c);; diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc index 42b5e5ab..4d3dc558 100644 --- a/contrib/interface/vernacrc +++ b/contrib/interface/vernacrc @@ -1,4 +1,4 @@ -# $Id: vernacrc,v 1.3 2004/01/14 14:52:59 bertot Exp $ +# $Id: vernacrc 5202 2004-01-14 14:52:59Z bertot $ # This file is loaded initially by ./vernacparser. diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index ff418523..166a0cbf 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -112,19 +112,12 @@ and fCOMMAND = function fFORMULA x2; fINT_LIST x3; fNODE "abstraction" 3 -| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) -> +| CT_add_field(x1, x2, x3, x4) -> fFORMULA x1; fFORMULA x2; fFORMULA x3; - fFORMULA x4; - fFORMULA x5; - fFORMULA x6; - fFORMULA x7; - fFORMULA x8; - fFORMULA x9; - fFORMULA x10; - fBINDING_LIST x11; - fNODE "add_field" 11 + fFORMULA_OPT x4; + fNODE "add_field" 4 | CT_add_natural_feature(x1, x2) -> fNATURAL_FEATURE x1; fID x2; @@ -407,6 +400,9 @@ and fCOMMAND = function 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; @@ -418,6 +414,9 @@ and fCOMMAND = function | 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 @@ -451,6 +450,7 @@ and fCOMMAND = function | 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; @@ -1153,12 +1153,12 @@ 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 x2; + fID_LIST x2; fFORMULA x3; fNODE "module_type_with_def" 3 | CT_module_type_with_mod(x1, x2, x3) -> fMODULE_TYPE x1; - fID x2; + fID_LIST x2; fID x3; fNODE "module_type_with_mod" 3 and fMODULE_TYPE_CHECK = function @@ -1281,6 +1281,7 @@ and fRED_COM = function 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 @@ -1545,6 +1546,12 @@ and fTACTIC_COM = function | 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 @@ -1649,12 +1656,12 @@ and fTACTIC_COM = function fID x2; fNODE "move_after" 2 | CT_new_destruct(x1, x2, x3) -> - fFORMULA_OR_INT x1; + (List.iter 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) -> - fFORMULA_OR_INT x1; + (List.iter fFORMULA_OR_INT x1); (* Pierre C. Est-ce correct? *) fUSING x2; fINTRO_PATT_OPT x3; fNODE "new_induction" 3 @@ -1697,19 +1704,21 @@ and fTACTIC_COM = function | CT_repeat(x1) -> fTACTIC_COM x1; fNODE "repeat" 1 -| CT_replace_with(x1, x2) -> +| CT_replace_with(x1, x2,x3,x4) -> fFORMULA x1; fFORMULA x2; - fNODE "replace_with" 2 + fCLAUSE x3; + fTACTIC_OPT x4; + fNODE "replace_with" 4 | CT_rewrite_lr(x1, x2, x3) -> fFORMULA x1; fSPEC_LIST x2; - fID_OPT x3; + fCLAUSE x3; fNODE "rewrite_lr" 3 | CT_rewrite_rl(x1, x2, x3) -> fFORMULA x1; fSPEC_LIST x2; - fID_OPT x3; + fCLAUSE x3; fNODE "rewrite_rl" 3 | CT_right(x1) -> fSPEC_LIST x1; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 02dc57de..60195229 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -3,7 +3,6 @@ open String;; open Char;; open Util;; -open Ast;; open Names;; open Ascent;; open Genarg;; @@ -64,11 +63,7 @@ let coercion_description t = !coercion_description_holder t;; let set_coercion_description f = coercion_description_holder:=f; ();; -let string_of_node_loc the_node = - match Util.unloc (loc the_node) with - (a,b) -> "(" ^ (string_of_int a) ^ ", " ^ (string_of_int b) ^ ")";; - -let xlate_error s = failwith ("Translation error: " ^ s);; +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;; @@ -118,8 +113,16 @@ 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 nums_to_int_ne_list n l = - CT_int_ne_list(CT_int n, 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 @@ -266,11 +269,13 @@ let rec xlate_match_pattern = | 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) - | CPatNumeral(_,n) -> + | CPatPrim (_,Numeral n) -> CT_coerce_NUM_to_MATCH_PATTERN - (CT_int_encapsulator(Bignat.bigint_to_string n)) + (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)) @@ -301,9 +306,11 @@ let rec decompose_last = function let make_fix_struct (n,bl) = let names = names_of_local_assums bl in let nn = List.length names in - if nn = 1 then ctv_ID_OPT_NONE - else if n < nn then xlate_id_opt(List.nth names n) - else xlate_error "unexpected result of parsing for Fixpoint";; + if nn = 1 || n = None then ctv_ID_OPT_NONE + else + let n = out_some n in + if n < nn then xlate_id_opt(List.nth names n) + else xlate_error "unexpected result of parsing for Fixpoint";; let rec xlate_binder = function @@ -329,8 +336,8 @@ and | 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) + (_,[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 @@ -373,14 +380,11 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) | CCases (_, _, [], _) -> assert false - | CCases (_, (Some _, _), _, _) -> xlate_error "NOT parsed: Cases with Some" - | CCases (_,(None, ret_type), tm::tml, eqns)-> + | 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)) - | COrderedCase (_,Term.IfStyle,po,c,[b1;b2]) -> - xlate_error "No more COrderedCase" | 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), @@ -393,27 +397,18 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function (xlate_formula c, xlate_return_info ret_info, xlate_formula b1, xlate_formula b2) - | COrderedCase (_,Term.LetStyle, po, c, [CLambdaN(_,[l,_],b)]) -> - CT_inductive_let(xlate_formula_opt po, - xlate_id_opt_ne_list l, - xlate_formula c, xlate_formula b) - | COrderedCase (_,c,v,e,l) -> - let case_string = match c with - Term.MatchStyle -> "Match" - | _ -> "Case" in - CT_elimc(CT_case "Case", xlate_formula_opt v, xlate_formula e, - CT_formula_list(List.map xlate_formula l)) | CSort(_, s) -> CT_coerce_SORT_TYPE_to_FORMULA(xlate_sort s) | CNotation(_, s, l) -> notation_to_formula s (List.map xlate_formula l) - | CNumeral(_, i) -> - CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bignat.bigint_to_string i)) + | 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, t) -> + | CCast (_, e,_, t) -> CT_coerce_TYPED_FORMULA_to_FORMULA (CT_typed_formula(xlate_formula e, xlate_formula t)) | CPatVar (_, (_,i)) when is_int_meta i -> @@ -430,11 +425,13 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function 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, bl, arf, ardef) = + let strip_mutrec (fid, (n, ro), bl, arf, ardef) = let (struct_arg,bl,arf,ardef) = + (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) + (* By the way, how could [bl = []] happen in V8 syntax ? *) if bl = [] then + let n = out_some n in let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in - let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) else (make_fix_struct (n, bl),bl,arf,ardef) in let arf = xlate_formula arf in @@ -485,20 +482,23 @@ let xlate_hyp = function let xlate_hyp_location = function - | AI (_,id), nums, (InHypTypeOnly,_) -> - CT_intype(xlate_ident id, nums_to_int_list nums) - | AI (_,id), nums, (InHypValueOnly,_) -> - CT_invalue(xlate_ident id, nums_to_int_list nums) - | AI (_,id), [], (InHyp,_) -> + | (nums, AI (_,id)), InHypTypeOnly -> + CT_intype(xlate_ident id, nums_or_var_to_int_list nums) + | (nums, AI (_,id)), InHypValueOnly -> + CT_invalue(xlate_ident id, nums_or_var_to_int_list nums) + | ([], AI (_,id)), InHyp -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | AI (_,id), a::l, (InHyp,_) -> + | (a::l, AI (_,id)), InHyp -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_unfold_occ (xlate_ident id, - CT_int_ne_list(CT_int a, nums_to_int_list_aux l))) - | MetaId _, _,_ -> + CT_int_ne_list(num_or_var_to_int a, + nums_or_var_to_int_list_aux l))) + | (_, 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 @@ -631,6 +631,7 @@ let rec xlate_intro_pattern = 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" let compute_INV_TYPE = function FullInversionClear -> CT_inv_clear @@ -676,11 +677,14 @@ let xlate_using = function let xlate_one_unfold_block = function ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid) | (n::nums, qid) -> - CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);; + CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums) +;; + +let xlate_with_names = function + IntroAnonymous -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE + | fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) -let xlate_intro_patt_opt = 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 @@ -722,20 +726,23 @@ and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = | Reference (Ident (_,s)) -> ident_tac s | ConstrMayEval(ConstrTerm a) -> CT_formula_marker(xlate_formula a) - | TacFreshId s -> CT_fresh(ctf_STRING_OPT s) + | 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 (l,c)) -> CT_simpl (CT_coerce_PATTERN_to_PATTERN_OPT (CT_pattern_occ - (CT_int_list(List.map (fun n -> CT_int n) l), xlate_formula c))) + (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) @@ -752,7 +759,7 @@ and xlate_red_tactic = | Pattern l -> let pat_list = List.map (fun (nums,c) -> CT_pattern_occ - (CT_int_list (List.map (fun x -> CT_int x) nums), + (CT_int_list (nums_or_var_to_int_list_aux nums), xlate_formula c)) l in (match pat_list with | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) @@ -788,6 +795,7 @@ and xlate_tactic = | 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) @@ -798,7 +806,8 @@ and xlate_tactic = xlate_tactic t) | TacProgress t -> CT_progress(xlate_tactic t) | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2) - | TacMatch (exp, rules) -> + | TacMatch (true,_,_) -> failwith "TODO: lazy match" + | TacMatch (false, exp, rules) -> CT_match_tac(xlate_tactic exp, match List.map (function @@ -814,11 +823,11 @@ and xlate_tactic = | [] -> assert false | fst::others -> CT_match_tac_rules(fst, others)) - | TacMatchContext (_,[]) -> failwith "" - | TacMatchContext (false,rule1::rules) -> + | TacMatchContext (_,_,[]) | TacMatchContext (true,_,_) -> failwith "" + | TacMatchContext (false,false,rule1::rules) -> CT_match_context(xlate_context_rule rule1, List.map xlate_context_rule rules) - | TacMatchContext (true,rule1::rules) -> + | TacMatchContext (false,true,rule1::rules) -> CT_match_context_reverse(xlate_context_rule rule1, List.map xlate_context_rule rules) | TacLetIn (l, t) -> @@ -855,18 +864,23 @@ and xlate_tactic = (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, s) -> CT_fail(xlate_id_or_int count, + | 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)) - | TacId "" -> CT_idtac ctf_STRING_OPT_NONE - | TacId s -> CT_idtac(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_tactic) tac_opt with + 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 @@ -903,7 +917,7 @@ and xlate_tac = | TacChange (Some(l,c), f, b) -> (* TODO LATER: combine with other constructions of pattern_occ *) CT_change_local( - CT_pattern_occ(CT_int_list(List.map (fun n -> CT_int n) l), + CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c), xlate_formula f, xlate_clause b) @@ -914,7 +928,7 @@ and xlate_tac = CT_discriminate_eq (xlate_quantified_hypothesis_opt (out_gen (wit_opt rawwit_quant_hyp) idopt)) - | TacExtend (_,"deq", [idopt]) -> + | TacExtend (_,"simplify_eq", [idopt]) -> let idopt1 = out_gen (wit_opt rawwit_quant_hyp) idopt in let idopt2 = match idopt1 with None -> CT_coerce_ID_OPT_to_ID_OR_INT_OPT @@ -927,6 +941,8 @@ and xlate_tac = CT_injection_eq (xlate_quantified_hypothesis_opt (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | 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 (id, n, fixtac_list) -> @@ -962,53 +978,75 @@ and xlate_tac = | TacRight bindl -> CT_right (xlate_bindings bindl) | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl) | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl) - | TacExtend (_,"replace", [c1; c2]) -> - let c1 = xlate_formula (out_gen rawwit_constr c1) in - let c2 = xlate_formula (out_gen rawwit_constr c2) in - CT_replace_with (c1, c2) - | TacExtend (_,"rewrite", [b; cbindl]) -> - 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_rewrite_lr (c, bindl, ctv_ID_OPT_NONE) - else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE) - | TacExtend (_,"rewritein", [b; cbindl; id]) -> - 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 (out_gen rawwit_ident id)) in - if b then CT_rewrite_lr (c, bindl, id) - else CT_rewrite_rl (c, bindl, id) - | TacExtend (_,"conditionalrewrite", [t; b; cbindl]) -> - let t = out_gen rawwit_tactic t in + | 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(b,cbindl,cl) -> + 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) + | 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 (_,"conditionalrewritein", [t; b; cbindl; id]) -> - let t = out_gen rawwit_tactic t in + | 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 (out_gen rawwit_ident id)) 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 (_,"dependentrewrite", [b; id_or_constr]) -> + | TacExtend (_,"dependent_rewrite", [b; c]) -> let b = out_gen Extraargs.rawwit_orient b in - (match genarg_tag id_or_constr with - | IdentArgType -> (*Dependent Rewrite/SubstHypInConcl*) - let id = xlate_ident (out_gen rawwit_ident id_or_constr) 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 - | ConstrArgType -> (*CutRewrite/SubstConcl*) - let c = xlate_formula (out_gen rawwit_constr id_or_constr) in - if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) - else CT_cutrewrite_rl (c, ctv_ID_OPT_NONE) - | _ -> xlate_error "") - | TacExtend (_,"dependentrewrite", [b; c; id]) -> (*CutRewrite in/SubstHyp*) + | _ -> 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 (out_gen rawwit_ident id) 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]) -> @@ -1021,6 +1059,8 @@ and xlate_tac = | 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 @@ -1031,14 +1071,16 @@ and xlate_tac = (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) -> + | 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)) -> + | 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 @@ -1048,21 +1090,25 @@ and xlate_tac = match t with [t0] -> CT_coerce_TACTIC_COM_to_TACTIC_OPT - (xlate_tactic(out_gen rawwit_tactic t0)) + (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; idl]) -> + | 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 + | 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 + | 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, @@ -1077,19 +1123,21 @@ and xlate_tac = 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 wit_int_or_var n with + (match out_gen rawwit_int_or_var n with | ArgVar _ -> xlate_error "" | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) | TacExtend (_,"eapply", [cbindl]) -> let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in let c = xlate_formula c and bindl = xlate_bindings bindl in CT_eapply (c, bindl) - | TacTrivial (Some []) -> CT_trivial - | TacTrivial None -> + | TacTrivial ([],Some []) -> CT_trivial + | TacTrivial ([],None) -> CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) - | TacTrivial (Some (id1::idl)) -> + | 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 (c,bindl) -> @@ -1111,7 +1159,7 @@ and xlate_tac = CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u) | TacCase (c1,sl) -> CT_casetac (xlate_formula c1, xlate_bindings sl) - | TacSimpleInduction (h,_) -> CT_induction (xlate_quantified_hypothesis h) + | TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h) | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h) | TacCut c -> CT_cut (xlate_formula c) | TacLApply c -> CT_use (xlate_formula c) @@ -1123,20 +1171,21 @@ and xlate_tac = 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 [] -> + | TacClear (false,[]) -> xlate_error "Clear expects a non empty list of identifiers" - | TacClear (id::idl) -> + | 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'" | (*For translating tactics/Inv.v *) TacInversion (NonDepInversion (k,idl,l),quant_hyp) -> CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp, - xlate_intro_patt_opt l, + 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_intro_patt_opt l, xlate_formula_opt copt) + 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, @@ -1148,28 +1197,34 @@ and xlate_tac = 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) - | TacNewDestruct(a,b,(c,_)) -> - CT_new_destruct - (xlate_int_or_constr a, xlate_using b, - xlate_intro_patt_opt c) - | TacNewInduction(a,b,(c,_)) -> - CT_new_induction - (xlate_int_or_constr a, xlate_using b, - xlate_intro_patt_opt c) - | TacInstantiate (a, b, cl) -> + | TacNewDestruct(a,b,c) -> + CT_new_destruct (* Julien F. : est-ce correct *) + (List.map xlate_int_or_constr a, xlate_using b, + xlate_with_names c) + | TacNewInduction(a,b,c) -> + CT_new_induction (* Pierre C. : est-ce correct *) + (List.map xlate_int_or_constr a, xlate_using b, + xlate_with_names c) + (*| TacInstantiate (a, b, cl) -> CT_instantiate(CT_int a, xlate_formula b, - xlate_clause cl) + assert false) *) + | TacLetTac (na, c, cl) when cl = nowhere -> + CT_pose(xlate_id_opt_aux na, xlate_formula c) | TacLetTac (na, c, cl) -> 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) - | TacForward (true, name, c) -> - CT_pose(xlate_id_opt_aux name, xlate_formula c) - | TacForward (false, name, c) -> - CT_assert(xlate_id_opt ((0,0),name), xlate_formula c) - | TacTrueCut (na, c) -> - CT_truecut(xlate_id_opt ((0,0),na), xlate_formula c) + | TacAssert (None, IntroIdentifier id, c) -> + CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) + | TacAssert (None, IntroAnonymous, c) -> + CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) + | TacAssert (Some (TacId []), IntroIdentifier id, c) -> + CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) + | TacAssert (Some (TacId []), IntroAnonymous, 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(Some tac) -> CT_any_constructor (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) @@ -1181,6 +1236,7 @@ and xlate_tac = (List.map xlate_formula (out_gen (wit_list0 rawwit_constr) args))) | 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" @@ -1216,8 +1272,11 @@ and coerce_genarg_to_TARG x = CT_coerce_FORMULA_OR_INT_to_TARG (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT id)) - | HypArgType -> - xlate_error "TODO (similar to IdentArgType)" + | 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 @@ -1233,19 +1292,15 @@ and coerce_genarg_to_TARG x = (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" - | TacticArgType -> - let t = xlate_tactic (out_gen rawwit_tactic x) in - CT_coerce_TACTIC_COM_to_TARG t - | OpenConstrArgType -> + | OpenConstrArgType b -> CT_coerce_SCOMMENT_CONTENT_to_TARG (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula - (snd (out_gen - rawwit_open_constr x)))) - | CastedOpenConstrArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula - (snd (out_gen - rawwit_casted_open_constr x)))) + (snd (out_gen + (rawwit_open_constr_gen b) x)))) + | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> + let n = out_some (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" @@ -1315,8 +1370,11 @@ let coerce_genarg_to_VARG x = CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT id)) - | HypArgType -> - xlate_error "TODO (similar to IdentArgType)" + | 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 @@ -1332,11 +1390,11 @@ let coerce_genarg_to_VARG x = (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" - | TacticArgType -> - let t = xlate_tactic (out_gen rawwit_tactic x) in + | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> + let n = out_some (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" - | CastedOpenConstrArgType -> xlate_error "TODO: generic open constr" + | 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" @@ -1347,23 +1405,9 @@ let coerce_genarg_to_VARG x = | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" -let xlate_thm x = CT_thm (match x with - | Theorem -> "Theorem" - | Remark -> "Remark" - | Lemma -> "Lemma" - | Fact -> "Fact") +let xlate_thm x = CT_thm (string_of_theorem_kind x) - -let xlate_defn x = CT_defn (match x with - | (Local, Definition) -> "Local" - | (Global, Definition) -> "Definition" - | (Global, SubClass) -> "SubClass" - | (Global, Coercion) -> "Coercion" - | (Local, SubClass) -> "Local SubClass" - | (Local, Coercion) -> "Local Coercion" - | (Global,CanonicalStructure) -> "Canonical Structure" - | (Local, CanonicalStructure) -> - xlate_error "Local CanonicalStructure not parsed") +let xlate_defn k = CT_defn (string_of_definition_kind k) let xlate_var x = CT_var (match x with | (Global,Definitional) -> "Parameter" @@ -1511,17 +1555,18 @@ let rec xlate_module_type = function | CMTEwith(mty, decl) -> let mty1 = xlate_module_type mty in (match decl with - CWith_Definition((_, id), c) -> - CT_module_type_with_def(xlate_module_type mty, - xlate_ident id, xlate_formula c) - | CWith_Module((_, id), (_, qid)) -> - CT_module_type_with_mod(xlate_module_type mty, - xlate_ident id, + 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)));; let xlate_module_binder_list (l:module_binder list) = CT_module_binder_list - (List.map (fun (idl, mty) -> + (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 @@ -1601,6 +1646,15 @@ let rec xlate_vernac = 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]) -> @@ -1621,40 +1675,22 @@ let rec xlate_vernac = CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) | VernacExtend("Field", - [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) -> + [fth;ainv;ainvl;div]) -> (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) - [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl] + [fth;ainv;ainvl] with - [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] -> - let bind = - match out_gen Field.rawwit_minus_div_arg minusdiv with - None, None -> - CT_binding_list[] - | Some m, None -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)] - | None, Some d -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] - | Some m, Some d -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m); - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in - CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1, - ainv1, fth1, ainvl1, bind) + [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 (("HintRewriteV7"|"HintRewriteV8") as key, largs) -> - let in_v8 = (key = "HintRewriteV8") in - let orient = out_gen Extraargs.rawwit_orient (List.nth largs 0) in - let formula_list = out_gen (wit_list1 rawwit_constr) (List.nth largs 1) in - let t = - if List.length largs = 4 then - out_gen rawwit_tactic (List.nth largs (if in_v8 then 2 else 3)) - else - TacId "" in - let base = - out_gen rawwit_pre_ident - (if in_v8 then last largs else List.nth largs 2) in + | 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 @@ -1665,7 +1701,7 @@ let rec xlate_vernac = | VernacHints (local,dbnames,h) -> let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in (match h with - | HintsConstructors (None, l) -> + | HintsConstructors l -> let n1, names = match List.map tac_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in @@ -1675,15 +1711,10 @@ let rec xlate_vernac = else CT_hints(CT_ident "Constructors", CT_id_ne_list(n1, names), dblist) - | HintsExtern (None, n, c, t) -> + | HintsExtern (n, c, t) -> CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist) | HintsResolve l | HintsImmediate l -> - let l = - List.map - (function (None, f) -> xlate_formula f - | _ -> - xlate_error "obsolete Hint Resolve not supported") l in - let f1, formulas = match l with + 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 @@ -1700,10 +1731,7 @@ let rec xlate_vernac = | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) | HintsUnfold l -> - let l = List.map - (function (None,ref) -> loc_qualid_to_ct_ID ref | - _ -> xlate_error "obsolete Hint Unfold not supported") l in - let n1, names = match l with + let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in if local then @@ -1724,9 +1752,6 @@ let rec xlate_vernac = CT_hint_destruct (xlate_ident id, CT_int n, dl, xlate_formula f, xlate_tactic t, dblist) - | HintsExtern(Some _, _, _, _) - | HintsConstructors(Some _, _) -> - xlate_error "obsolete Hint Constructors not supported" ) | VernacEndProof (Proved (true,None)) -> CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), ctv_ID_OPT_NONE) @@ -1759,9 +1784,11 @@ let rec xlate_vernac = | 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 -> + | 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 -> @@ -1775,6 +1802,8 @@ let rec xlate_vernac = | 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 @@ -1783,12 +1812,15 @@ let rec xlate_vernac = | 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" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) - | PrintLocalContext -> CT_print + | PrintSetoids -> CT_print_setoids | 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) @@ -1809,7 +1841,7 @@ let rec xlate_vernac = CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, xlate_binder_list bl, xlate_formula c)) | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt)) + | 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 @@ -1851,7 +1883,7 @@ let rec xlate_vernac = (_, (add_coercion, (_,s)), binders, c1, rec_constructor_or_none, field_list) -> let record_constructor = - xlate_ident_opt (option_app snd rec_constructor_or_none) in + 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)), @@ -1860,20 +1892,22 @@ let rec xlate_vernac = build_record_field_list field_list) | VernacInductive (isind, lmi) -> let co_or_ind = if isind then "Inductive" else "CoInductive" in - let strip_mutind ((_,s), notopt, parameters, c, constructors) = + let strip_mutind (((_,s), parameters, c, constructors), notopt) = CT_ind_spec (xlate_ident s, xlate_binder_list parameters, xlate_formula c, build_constructors constructors, translate_opt_notation_decl notopt) 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) -> - let strip_mutrec ((fid, n, bl, arf, ardef), ntn) = + | VernacFixpoint ([],_) -> xlate_error "mutual recursive" + | VernacFixpoint ((lm :: lmi),boxed) -> + let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) = let (struct_arg,bl,arf,ardef) = + (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) + (* By the way, how could [bl = []] happen in V8 syntax ? *) if bl = [] then + let n = out_some n in let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in - let bl = List.map (fun(nal,ty)->LocalRawAssum(nal,ty)) bl in (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) else (make_fix_struct (n, bl),bl,arf,ardef) in let arf = xlate_formula arf in @@ -1885,9 +1919,9 @@ let rec xlate_vernac = | _ -> xlate_error "mutual recursive" in CT_fix_decl (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) - | VernacCoFixpoint [] -> xlate_error "mutual corecursive" - | VernacCoFixpoint (lm :: lmi) -> - let strip_mutcorec (fid, bl, arf, ardef) = + | 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 @@ -1916,20 +1950,18 @@ let rec xlate_vernac = | Some mty1 -> CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT (xlate_module_type mty1)) - | VernacDefineModule((_, id), bl, mty_o, mexpr_o) -> + | 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, mexpr_o) -> + | VernacDeclareModule(_,(_, id), bl, mty_o) -> CT_declare_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) + 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, @@ -1943,13 +1975,11 @@ let rec xlate_vernac = CT_require(ct_impexp, ct_spec, CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) - | VernacSyntax (phylum, l) -> xlate_error "SYNTAX not implemented" - | 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(qid, l) -> + | VernacArgumentsScope(true, qid, l) -> CT_arguments_scope(loc_qualid_to_ct_ID qid, CT_id_opt_list (List.map @@ -1957,6 +1987,8 @@ let rec xlate_vernac = 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 @@ -1966,8 +1998,7 @@ let rec xlate_vernac = CT_id_ne_list(xlate_class_rawexpr a, List.map xlate_class_rawexpr l)) | VernacBindScope(id, []) -> assert false - | VernacNotation(b, c, None, _, _) -> assert false - | VernacNotation(b, c, Some(s,modif_list), _, opt_scope) -> + | 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 = @@ -1981,7 +2012,7 @@ let rec xlate_vernac = else CT_define_notation(translated_s, formula, translated_modif_list, translated_scope) - | VernacSyntaxExtension(b,Some(s,modif_list), None) -> + | 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 @@ -1989,8 +2020,7 @@ let rec xlate_vernac = CT_local_reserve_notation(translated_s, translated_modif_list) else CT_reserve_notation(translated_s, translated_modif_list) - | VernacSyntaxExtension(_, _, _) -> assert false - | VernacInfix (b,(str,modl),id,_, opt_scope) -> + | 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 @@ -2001,7 +2031,6 @@ let rec xlate_vernac = CT_local_infix(s, id1,modl1, translated_scope) else CT_infix(s, id1,modl1, translated_scope) - | VernacGrammar _ -> xlate_error "GRAMMAR not implemented" | VernacCoercion (s, id1, id2, id3) -> let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in let local_opt = @@ -2026,18 +2055,15 @@ let rec xlate_vernac = | VernacExtend (s, l) -> CT_user_vernac (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacDebug b -> xlate_error "Debug On/Off not supported" | 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 - | (VernacV7only _ | VernacV8only _) -> - xlate_error "Not treated here" | VernacNop -> CT_proof_no_op | VernacComments l -> CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) - | VernacDeclareImplicits(id, opt_positions) -> + | VernacDeclareImplicits(true, id, opt_positions) -> CT_implicits (reference_to_ct_ID id, match opt_positions with @@ -2050,6 +2076,8 @@ let rec xlate_vernac = -> 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), @@ -2057,6 +2085,7 @@ let rec xlate_vernac = | 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) @@ -2113,9 +2142,9 @@ let rec xlate_vernac = | VernacVar _ -> xlate_error "Grammar vernac obsolete" | (VernacGlobalCheck _|VernacPrintOption _| VernacMemOption (_, _)|VernacRemoveOption (_, _) - | VernacBack _|VernacRestoreState _| VernacWriteState _| - VernacSolveExistential (_, _)|VernacCanonical _ | VernacDistfix _| - VernacTacticGrammar _) + | VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _| + VernacSolveExistential (_, _)|VernacCanonical _ | + VernacTacticNotation _) -> xlate_error "TODO: vernac";; let rec xlate_vernac_list = @@ -2123,8 +2152,5 @@ let rec xlate_vernac_list = | VernacList (v::l) -> CT_command_list (xlate_vernac (snd v), List.map (fun (_,x) -> xlate_vernac x) l) - | VernacV7only v -> - if !Options.v7 then xlate_vernac_list v - else xlate_error "Unknown command" | VernacList [] -> xlate_error "xlate_command_list" | _ -> xlate_error "Not a list of commands";; diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml index 876dc6c0..a2a72676 100644 --- a/contrib/jprover/jall.ml +++ b/contrib/jprover/jall.ml @@ -1788,11 +1788,13 @@ struct else if o = ("",Orr,dummyt,dummyt) then (* Orr is a dummy for no d-gen. rule *) ptree else +(* let (x1,x2,x3,x4) = r and (y1,y2,y3,y4) = o in -(* print_endline ("top or_l: "^x1); + print_endline ("top or_l: "^x1); print_endline ("or_l address: "^addr); - print_endline ("top dgen-rule: "^y1); *) + print_endline ("top dgen-rule: "^y1); +*) trans_add_branch r o addr "" ptree dglist (subrel,tsubrel) (* Isolate layer and outer recursion structure *) @@ -1989,8 +1991,7 @@ struct let (srel,sren) = build_formula_rel dtreelist slist predname in (srel @ rest_rel),(sren @ rest_renlist) | Gamma -> - let n = Array.length suctrees - and succlist = (Array.to_list suctrees) in + let succlist = (Array.to_list suctrees) in let dtreelist = (List.map (fun x -> (1,x)) succlist) in (* if (nonemptys suctrees 0 n) = 1 then let (srel,sren) = build_formula_rel dtreelist slist pos.name in @@ -3039,8 +3040,7 @@ struct if (p.pt = Delta) then (* keep the tree ordering for the successor position only *) let psucc = List.hd succs in let ppsuccs = tpredsucc psucc ftree in - let pre = List.hd ppsuccs - and sucs = List.tl ppsuccs in + let sucs = List.tl ppsuccs in replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *) else redpo @@ -4582,7 +4582,6 @@ let gen_prover mult_limit logic calculus hyps concls = let (input_map,renamed_termlist) = renam_free_vars (hyps @ concls) in let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in let sequent_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in - let (ptree,count_ax) = bproof sequent_proof in let idl = build_formula_id ftree in (* print_ftree ftree; apple *) (* transform types and rename constants *) diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4 index dd76438f..294943f7 100644 --- a/contrib/jprover/jprover.ml4 +++ b/contrib/jprover/jprover.ml4 @@ -51,7 +51,7 @@ let mbreak s = Format.print_flush (); print_string ("-break at: "^s); let jp_error re = raise (JT.RefineError ("jprover", JT.StringError re)) (* print Coq constructor *) -let print_constr ct = Pp.ppnl (PR.prterm ct); Format.print_flush () +let print_constr ct = Pp.ppnl (PR.pr_lconstr ct); Format.print_flush () let rec print_constr_list = function | [] -> () @@ -361,7 +361,7 @@ let dyn_impl id gl = (TCL.tclTHENLAST (TCL.tclTHENS (T.cut b) [T.intro_using id2;TCL.tclIDTAC]) (T.apply_term (TR.mkVar (short_addr id)) - [TR.mkMeta (Clenv.new_meta())])) gl + [TR.mkMeta (Evarutil.new_meta())])) gl let dyn_allr c = (* [c] must be an eigenvariable which replaces [v] *) HT.h_intro (N.id_of_string c) @@ -390,7 +390,7 @@ let dyn_truer = (* Do the proof by the guidance of JProver. *) let do_one_step inf = - let (rule, (s1, t1), ((s2, t2) as k)) = inf in + let (rule, (s1, t1), (s2, t2)) = inf in begin (*i if not (Jterm.is_xnil_term t2) then begin @@ -542,20 +542,9 @@ let jpn n gls = TCL.tclTHEN (TCL.tclTRY T.red_in_concl) (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) (jp n)) gls -(* -let dyn_jpn l gls = - match l with - | [PT.Integer n] -> jpn n - | _ -> jp_error "Impossible!!!" - - -let h_jp = TM.hide_tactic "Jp" dyn_jp - -let h_jpn = TM.hide_tactic "Jpn" dyn_jpn -*) -TACTIC EXTEND Jprover - [ "Jp" natural_opt(n) ] -> [ jpn n ] +TACTIC EXTEND jprover + [ "jp" natural_opt(n) ] -> [ jpn n ] END (* diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml index 2295e62c..91aa6b4b 100644 --- a/contrib/jprover/jtunify.ml +++ b/contrib/jprover/jtunify.ml @@ -177,7 +177,7 @@ let rec combine subst ((ov,oslist) as one_subst) = else (f::rest_combine) -let compose ((n,subst) as sigma) ((ov,oslist) as one_subst) = +let compose ((n,subst) as _sigma) ((ov,oslist) as one_subst) = let com = combine subst one_subst in (* begin print_endline "!!!!!!!!!test print!!!!!!!!!!"; diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v index e72dcec2..66f86a49 100755..100644 --- a/contrib/omega/Omega.v +++ b/contrib/omega/Omega.v @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: Omega.v,v 1.10.2.1 2004/07/16 19:30:12 herbelin Exp $ *) +(* $Id: Omega.v 8642 2006-03-17 10:09:02Z notin $ *) (* We do not require [ZArith] anymore, but only what's necessary for Omega *) Require Export ZArith_base. diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v index 6f0ea2c6..ae642a3e 100644 --- a/contrib/omega/OmegaLemmas.v +++ b/contrib/omega/OmegaLemmas.v @@ -1,45 +1,45 @@ -(************************************************************************) -(* 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 *) -(************************************************************************) +(***********************************************************************) +(* 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,v 1.4.2.1 2004/07/16 19:30:12 herbelin Exp $ i*) +(*i $Id: OmegaLemmas.v 7727 2005-12-25 13:42:20Z herbelin $ i*) Require Import ZArith_base. +Open Local Scope Z_scope. (** These are specific variants of theorems dedicated for the Omega tactic *) -Lemma new_var : forall x:Z, exists y : Z, x = y. +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)%Z -> (0 <= y)%Z. +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)%Z -> (0 <= y)%Z -> (0 <= x + y)%Z. +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)%Z -> x = (y * k)%Z -> x = 0%Z -> y = 0%Z. +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)%Z; + [ 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)%Z -> (y > x)%Z -> (z * y + x)%Z <> 0%Z. +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)%Z; - [ intros H4; cut (0 <= z * y + x)%Z; +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)%Z; + 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); @@ -55,48 +55,44 @@ unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0)%Z; | apply Zgt_trans with x; [ assumption | assumption ] ]. Qed. -Lemma OMEGA5 : forall x y z:Z, x = 0%Z -> y = 0%Z -> (x + y * z)%Z = 0%Z. +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)%Z -> y = 0%Z -> (0 <= x + y * z)%Z. +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)%Z -> - (t > 0)%Z -> (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x * z + y * t)%Z. + 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)%Z -> (0 <= y)%Z -> x = (- y)%Z -> x = 0%Z. +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)%Z; - [ change (0 >= x)%Z in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; + [ 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%Z -> x = z -> (y + (- x + z) * t)%Z = 0%Z. +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)%Z = - (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))%Z. + 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; @@ -104,8 +100,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; Qed. Lemma OMEGA11 : - forall v1 c1 l1 l2 k1:Z, - ((v1 * c1 + l1) * k1 + l2)%Z = (v1 * (c1 * k1) + (l1 * k1 + l2))%Z. + 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; @@ -113,8 +109,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; Qed. Lemma OMEGA12 : - forall v2 c2 l1 l2 k2:Z, - (l1 + (v2 * c2 + l2) * k2)%Z = (v2 * (c2 * k2) + (l1 + l2 * k2))%Z. + 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; @@ -122,8 +118,8 @@ intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; Qed. Lemma OMEGA13 : - forall (v l1 l2:Z) (x:positive), - (v * Zpos x + l1 + (v * Zneg x + l2))%Z = (l1 + l2)%Z. + 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; @@ -133,8 +129,8 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); Qed. Lemma OMEGA14 : - forall (v l1 l2:Z) (x:positive), - (v * Zneg x + l1 + (v * Zpos x + l2))%Z = (l1 + l2)%Z. + 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; @@ -142,128 +138,126 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1); 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)%Z = - (v * (c1 + c2 * k2) + (l1 + l2 * k2))%Z. + 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)%Z = (v * (c * k) + l * k)%Z. +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%Z -> Zne (x + y * z) 0. +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)%Z; rewrite Zplus_comm; + 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)%Z -> Zne x 0 -> Zne y 0. +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)%Z \/ (0 <= x * -1 + -1)%Z. +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)%Z in |- *; apply Zsucc_le_reg; + [ 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%Z); auto with arith ] + | 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%Z -> Zne (x + y * z) 0. +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_sym (x y:Z) (P:Z -> Prop) (H:P (y + x)%Z) := - eq_ind_r P H (Zplus_comm x y). +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_r (n m p:Z) (P:Z -> Prop) - (H:P (n + (m + p))%Z) := eq_ind_r P H (Zplus_assoc_reverse n m p). +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_l (n m p:Z) (P:Z -> Prop) - (H:P (n + m + p)%Z) := eq_ind_r P H (Zplus_assoc 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))%Z) := eq_ind_r P H (Zplus_permute 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))%Z) := +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))%Z) := +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))%Z) := +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))%Z) := +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)%Z) := eq_ind_r P H (OMEGA16 v c l k). +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)%Z) := eq_ind_r P H (OMEGA13 v l1 l2 x). +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)%Z) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x:Z) (P:Z -> Prop) (H:P (x * 1)%Z) := - eq_ind_r P H (Zred_factor0 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_one (x:Z) (P:Z -> Prop) (H:P (x * -1)%Z) := - eq_ind_r P H (Zopp_eq_mult_neg_1 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_sym (x y:Z) (P:Z -> Prop) (H:P (y * x)%Z) := - eq_ind_r P H (Zmult_comm x y). +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_Zplus (x y:Z) (P:Z -> Prop) (H:P (- x + - y)%Z) := - eq_ind_r P H (Zopp_plus_distr 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_Zopp (x:Z) (P:Z -> Prop) (H:P x) := +Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := eq_ind_r P H (Zopp_involutive x). -Definition fast_Zopp_Zmult_r (x y:Z) (P:Z -> Prop) - (H:P (x * - y)%Z) := eq_ind_r P H (Zopp_mult_distr_r x y). +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 (n m p:Z) (P:Z -> Prop) - (H:P (n * p + m * p)%Z) := eq_ind_r P H (Zmult_plus_distr_l n m p). -Definition fast_Zmult_Zopp_left (x y:Z) (P:Z -> Prop) - (H:P (x * - y)%Z) := eq_ind_r P H (Zmult_opp_comm 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_r (n m p:Z) (P:Z -> Prop) - (H:P (n * (m * p))%Z) := eq_ind_r P H (Zmult_assoc_reverse n m p). +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)%Z) := - eq_ind_r P H (Zred_factor1 x). +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))%Z) := eq_ind_r P H (Zred_factor2 x y). -Definition fast_Zred_factor3 (x y:Z) (P:Z -> Prop) - (H:P (x * (1 + y))%Z) := eq_ind_r P H (Zred_factor3 x y). +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_factor4 (x y z:Z) (P:Z -> Prop) - (H:P (x * (y + z))%Z) := eq_ind_r P H (Zred_factor4 x y z). +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_factor5 (x y:Z) (P:Z -> Prop) - (H:P y) := eq_ind_r P H (Zred_factor5 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_factor6 (x:Z) (P:Z -> Prop) (H:P (x + 0)%Z) := - eq_ind_r P H (Zred_factor6 x). +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/coq_omega.ml b/contrib/omega/coq_omega.ml index 7a20aeb6..da0817d1 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,13 +13,12 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml,v 1.59.2.3 2004/07/16 19:30:12 herbelin Exp $ *) +(* $Id: coq_omega.ml 8934 2006-06-09 14:30:12Z herbelin $ *) open Util open Pp open Reduction open Proof_type -open Ast open Names open Nameops open Term @@ -36,9 +35,11 @@ open Clenv open Logic open Libnames open Nametab -open Omega 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 @@ -56,16 +57,6 @@ let write f x = f:=x open Goptions -(* Obsolete, subsumed by Time Omega -let _ = - declare_bool_option - { optsync = false; - optname = "Omega time displaying flag"; - optkey = SecondaryTable ("Omega","Time"); - optread = read display_time_flag; - optwrite = write display_time_flag } -*) - let _ = declare_bool_option { optsync = false; @@ -110,6 +101,31 @@ 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 (Some 1) 1 (Rawterm.ImplicitBindings [c]) @@ -146,32 +162,34 @@ let hide_constr,find_constr,clear_tables,dump_tables = open Coqlib let logic_dir = ["Coq";"Logic";"Decidable"] +let init_arith_modules = init_modules @ arith_modules let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_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_ZERO = lazy (constant (if !Options.v7 then "ZERO" else "Z0")) -let coq_POS = lazy (constant (if !Options.v7 then "POS" else "Zpos")) -let coq_NEG = lazy (constant (if !Options.v7 then "NEG" else "Zneg")) +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_relation = lazy (constant (if !Options.v7 then "relation" else "comparison")) -let coq_SUPERIEUR = lazy (constant "SUPERIEUR") -let coq_INFEEIEUR = lazy (constant "INFERIEUR") -let coq_EGAL = lazy (constant "EGAL") +let coq_comparison = lazy (constant "comparison") +let coq_Gt = lazy (constant "Gt") +let coq_INFEEIEUR = lazy (constant "Lt") +let coq_Eq = lazy (constant "Eq") 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_Zs = lazy (constant "Zs") +let coq_Zsucc = lazy (constant "Zsucc") let coq_Zgt = lazy (constant "Zgt") let coq_Zle = lazy (constant "Zle") -let coq_inject_nat = lazy (constant "inject_nat") +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") @@ -183,12 +201,12 @@ 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_r = lazy (constant "fast_Zplus_assoc_r") -let coq_fast_Zplus_assoc_l = lazy (constant "fast_Zplus_assoc_l") -let coq_fast_Zmult_assoc_r = lazy (constant "fast_Zmult_assoc_r") +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_sym = lazy (constant "fast_Zplus_sym") -let coq_fast_Zmult_sym = lazy (constant "fast_Zmult_sym") +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") @@ -217,12 +235,12 @@ 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 = lazy (constant "fast_Zmult_plus_distr") -let coq_fast_Zmult_Zopp_left = lazy (constant "fast_Zmult_Zopp_left") -let coq_fast_Zopp_Zplus = lazy (constant "fast_Zopp_Zplus") -let coq_fast_Zopp_Zmult_r = lazy (constant "fast_Zopp_Zmult_r") -let coq_fast_Zopp_one = lazy (constant "fast_Zopp_one") -let coq_fast_Zopp_Zopp = lazy (constant "fast_Zopp_Zopp") +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") @@ -240,10 +258,10 @@ 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_not_Zle = lazy (constant "not_Zle") -let coq_not_Zlt = lazy (constant "not_Zlt") -let coq_not_Zge = lazy (constant "not_Zge") -let coq_not_Zgt = lazy (constant "not_Zgt") +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") @@ -252,17 +270,17 @@ let coq_Zge = lazy (constant "Zge") let coq_Zlt = lazy (constant "Zlt") (* Peano/Datatypes *) -let coq_le = lazy (constant "le") -let coq_lt = lazy (constant "lt") -let coq_ge = lazy (constant "ge") -let coq_gt = lazy (constant "gt") -let coq_minus = lazy (constant "minus") -let coq_plus = lazy (constant "plus") -let coq_mult = lazy (constant "mult") -let coq_pred = lazy (constant "pred") -let coq_nat = lazy (constant "nat") -let coq_S = lazy (constant "S") -let coq_O = lazy (constant "O") +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") @@ -304,7 +322,7 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with EvalConstRef kn | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") -let sp_Zs = lazy (evaluable_ref_of_constr "Zs" coq_Zs) +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) @@ -324,23 +342,23 @@ 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_relation; t1; t2 |]) -let mk_inj t = mkApp (Lazy.force coq_inject_nat, [| t |]) + [| 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=1 then Lazy.force coq_xH else - mkApp ((if n mod 2 = 0 then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/2) |]) + 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 = 0 then Lazy.force coq_ZERO - else mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG), + 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 | Zs | Zopp + | Zplus | Zmult | Zminus | Zsucc | Zopp | Plus | Mult | Minus | Pred | S | O - | POS | NEG | ZERO | Inject_nat + | Zpos | Zneg | Z0 | Z_of_nat | Eq | Neq | Zne | Zle | Zlt | Zge | Zgt | Z | Nat @@ -401,7 +419,7 @@ let destructurate_term t = | _, [_;_] 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_Zs -> Kapp (Zs,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) @@ -409,25 +427,25 @@ let destructurate_term t = | _, [_] 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_POS -> Kapp (NEG,args) - | _, [_] when c = Lazy.force coq_NEG -> Kapp (POS,args) - | _, [] when c = Lazy.force coq_ZERO -> Kapp (ZERO,args) - | _, [_] when c = Lazy.force coq_inject_nat -> Kapp (Inject_nat,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 -> 1 + 2 * loop t - | f, [t] when f = Lazy.force coq_xO -> 2 * loop t - | f, [] when f = Lazy.force coq_xH -> 1 + | 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_POS -> loop t - | f, [t] when f = Lazy.force coq_NEG -> - (loop t) - | f, [] when f = Lazy.force coq_ZERO -> 0 + | 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 = @@ -443,13 +461,11 @@ type constr_path = let context operation path (t : constr) = let rec loop i p0 t = match (p0,kind_of_term t) with - | (p, Cast (c,t)) -> mkCast (loop i p c,t) + | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> -(* let f,l = get_applist t in NECESSAIRE ?? - let v' = Array.of_list (f::l) in *) let v' = Array.copy v in - v'.(n-1) <- loop i p v'.(n-1); mkApp (f, v') + 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 @@ -462,13 +478,13 @@ let context operation path (t : constr) = | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in - v'.(n) <- loop (i+l) p v.(n); (mkFix (ln,(tys,lna,v'))) + 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 (i+1) p c)) + (mkProd (n,t,loop (succ i) p c)) | ((P_BODY :: p), Lambda (n,t,c)) -> - (mkLambda (n,t,loop (i+1) p c)) + (mkLambda (n,t,loop (succ i) p c)) | ((P_BODY :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,t,loop (i+1) p 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)) -> @@ -476,16 +492,16 @@ let context operation path (t : constr) = | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> - ppnl (Printer.prterm t); + 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,t)) -> loop p c + | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t - | ((P_APP n :: p), App (f,v)) -> loop p v.(n-1) + | ((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) @@ -497,7 +513,7 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> - ppnl (Printer.prterm t); + ppnl (Printer.pr_lconstr t); failwith ("occurence " ^ string_of_int(List.length p)) in loop path t @@ -509,7 +525,7 @@ let abstract_path typ path t = 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 gl + convert_concl_no_check newc DEFAULTcast gl let focused_simpl path = simpl_time (focused_simpl path) @@ -518,7 +534,7 @@ type oformula = | Oinv of oformula | Otimes of oformula * oformula | Oatom of identifier - | Oz of int + | Oz of bigint | Oufo of constr let rec oprint = function @@ -530,7 +546,7 @@ let rec oprint = function print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" | Oatom s -> print_string (string_of_id s) - | Oz i -> print_int i + | Oz i -> print_string (string_of_bigint i) | Oufo f -> print_string "?" let rec weight = function @@ -567,7 +583,7 @@ let rec decompile af = in loop af.body -let mkNewMeta () = mkMeta (Clenv.new_meta()) +let mkNewMeta () = mkMeta (Evarutil.new_meta()) let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in @@ -606,7 +622,7 @@ let clever_rewrite p vpath t gl = 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) -> @@ -614,7 +630,7 @@ let rec shuffle p (t1,t2) = 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_r) + (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) else @@ -627,12 +643,12 @@ let rec shuffle p (t1,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_r) + (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_sym)], + (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) | t1,Oplus(l2,r2) -> if weight l2 > weight t1 then @@ -643,11 +659,11 @@ let rec shuffle p (t1,t2) = Oplus(l2,t') else [],Oplus(t1,t2) | Oz t1,Oz t2 -> - [focused_simpl p], Oz(t1+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_sym)], + (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) else [],Oplus(t1,t2) @@ -665,7 +681,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) in - if k1*c1 + k2 * c2 = 0 then + 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 @@ -722,7 +738,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) in - if c1 + k2 * c2 = 0 then + 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) @@ -732,7 +748,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 = 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_r) :: + (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]; @@ -744,7 +760,7 @@ let rec shuffle_mult_right p_init e1 k2 e2 = 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_r) :: + (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]; @@ -765,7 +781,7 @@ let rec shuffle_cancel p = function 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 > 0 then + (if c1 >? zero then (Lazy.force coq_fast_OMEGA13) else (Lazy.force coq_fast_OMEGA14)) @@ -777,15 +793,15 @@ let rec scalar p n = function 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) :: + (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_Zopp_left); - focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(-n)) + (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_r); + (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" @@ -809,7 +825,7 @@ let rec norm_add p_init = | [] -> [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_r) :: + (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) l in loop p_init @@ -831,31 +847,31 @@ let rec negate p = function 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_Zplus) :: + (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_Zopp)], 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_Zmult_r); - focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (-x)) + (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(-1)) in - [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_one)], r - | Oz i -> [focused_simpl p],Oz(-i) + 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 () = + let default isnat t' = try - let v,th,_ = find_constr t in + 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 false; + hide_constr t' v th isnat; [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v in try match destructurate_term t with @@ -870,10 +886,10 @@ let rec transform p t = (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in unfold sp_Zminus :: tac,t - | Kapp(Zs,[t1]) -> + | Kapp(Zsucc,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer 1 |])) in - unfold sp_Zs :: tac,t + [| 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 @@ -882,40 +898,32 @@ let rec transform p t = | (Oz n,_) -> let sym = clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_sym) in + (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' - | _ -> default () + | _ -> default false t end - | Kapp((POS|NEG|ZERO),_) -> - (try ([],Oz(recognize_number t)) with _ -> default ()) + | 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(Inject_nat,[t']) -> - begin 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 true; - [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - end - | _ -> default () - with e when catchable_exception e -> default () + | 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 2) in + 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 1)) in + 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 1)) in + 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) -> @@ -931,13 +939,13 @@ let shrink_pair p f1 f2 = let reduce_factor p = function | Oatom v -> - let r = Otimes(Oatom v,Oz 1) in + 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) -> compute t1 + compute t2 + | 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)) @@ -950,7 +958,7 @@ let rec condense p = function 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_l) in + (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 @@ -958,7 +966,7 @@ let rec condense p = function let tac',t' = condense (P_APP 2 :: p) t in (tac @ tac'), Oplus(f,t') end - | Oplus(f1,Oz n) as t -> + | 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 @@ -973,12 +981,12 @@ let rec condense p = function | Oz _ as t -> [],t | t -> let tac,t' = reduce_factor p t in - let final = Oplus(t',Oz 0) 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 0),r) -> + | 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 @@ -992,7 +1000,7 @@ 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 zero = mk_integer 0 in + let izero = mk_integer zero in let rec loop t = match t with | HYP e :: l -> @@ -1007,7 +1015,7 @@ let replay_history tactic_normalisation = 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 (-1) else 1 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 [ @@ -1028,11 +1036,10 @@ let replay_history tactic_normalisation = let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let superieur = Lazy.force coq_SUPERIEUR in let not_sup_sup = mkApp (build_coq_eq (), [| - Lazy.force coq_relation; - Lazy.force coq_SUPERIEUR; - Lazy.force coq_SUPERIEUR |]) + Lazy.force coq_comparison; + Lazy.force coq_Gt; + Lazy.force coq_Gt |]) in tclTHENS (tclTHENLIST [ @@ -1070,7 +1077,7 @@ let replay_history tactic_normalisation = (intros_using [id]); (cut (mk_gt kk dd)) ]) [ tclTHENS - (cut (mk_gt kk zero)) + (cut (mk_gt kk izero)) [ tclTHENLIST [ (intros_using [aux1; aux2]); (generalize_tac @@ -1088,20 +1095,16 @@ let replay_history tactic_normalisation = tclTHEN (mk_then tac) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> - let id = hyp_of_tag e1.id in let c = floor_div e1.constant k in - let d = e1.constant - c * 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 eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in + let 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_eq = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 2] e2.body in tclTHENS - (cut (mk_gt dd zero)) + (cut (mk_gt dd izero)) [ tclTHENS (cut (mk_gt kk dd)) [tclTHENLIST [ (intros_using [aux2;aux1]); @@ -1147,7 +1150,7 @@ let replay_history tactic_normalisation = tclTHENS (cut state_eq) [ tclTHENS - (cut (mk_gt kk zero)) + (cut (mk_gt kk izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac @@ -1170,7 +1173,7 @@ let replay_history tactic_normalisation = and eq2 = val_of (decompile (negate_eq e1)) in let tac = clever_rewrite [P_APP 3] [[P_APP 1]] - (Lazy.force coq_fast_Zopp_one) :: + (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body in tclTHENS @@ -1184,13 +1187,13 @@ let replay_history tactic_normalisation = (loop l) ]; tclTHEN (mk_then tac) reflexivity] - | STATE(new_eq,def,orig,m,sigma) :: l -> + | 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 new_eq.id; + tag_hypothesis id e.id; let eq1 = val_of(decompile def) and eq2 = val_of(decompile orig) in - let vid = unintern_id sigma in + let vid = unintern_id v in let theorem = mkApp (build_coq_ex (), [| Lazy.force coq_Z; @@ -1201,12 +1204,11 @@ let replay_history tactic_normalisation = in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in - let r = mk_plus eq2 (mk_times (mk_plus (mk_inv (mkVar vid)) eq1) mm) in let tac = clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) - [[P_APP 1]] (Lazy.force coq_fast_Zopp_one) :: + [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial - orig.body m ({c= -1;v=sigma}::def.body) in + orig.body m ({c= negone;v= v}::def.body) in tclTHENS (cut theorem) [tclTHENLIST [ @@ -1241,7 +1243,7 @@ let replay_history tactic_normalisation = and id2 = hyp_of_tag e2.id in let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in - if k1 = 1 & e2.kind = EQUA then + if k1 =? one & e2.kind = EQUA then let tac_thm = match e1.kind with | EQUA -> Lazy.force coq_OMEGA5 @@ -1264,9 +1266,9 @@ let replay_history tactic_normalisation = 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 zero)) + tclTHENS (cut (mk_gt kk1 izero)) [tclTHENS - (cut (mk_gt kk2 zero)) + (cut (mk_gt kk2 izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac @@ -1345,7 +1347,7 @@ let destructure_omega gl tac_def (id,c) = 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 (-1))) (mk_inv t1) in + 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]) -> @@ -1353,7 +1355,7 @@ let destructure_omega gl tac_def (id,c) = 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 (-1))) (mk_inv t2) in + 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 @@ -1362,7 +1364,7 @@ let destructure_omega gl tac_def (id,c) = 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 = @@ -1382,8 +1384,8 @@ let coq_omega gl = (intros_using [th;id]); tac ]), {kind = INEQ; - body = [{v=intern_id v; c=1}]; - constant = 0; id = i} :: sys + body = [{v=intern_id v; c=one}]; + constant = zero; id = i} :: sys else (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); @@ -1393,17 +1395,19 @@ let coq_omega gl = (tclIDTAC,[]) (dump_tables ()) in let system = system @ sys in - if !display_system_flag then display_system system; + if !display_system_flag then display_system display_var system; if !old_style_flag then begin - try let _ = simplify false system in tclIDTAC gl + 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 path; + 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 system in - if !display_action_flag then display_action path; + 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 @@ -1411,8 +1415,6 @@ let coq_omega gl = let coq_omega = solver_time coq_omega let nat_inject gl = - let aux = id_of_string "auxiliary" in - let table = Hashtbl.create 7 in let rec explore p t = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> @@ -1444,7 +1446,7 @@ let nat_inject gl = (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; (tclTHEN - (clever_rewrite_gen p (mk_integer 0) + (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 |])])) ] @@ -1461,7 +1463,7 @@ let nat_inject gl = Kapp(S,[t]) -> (tclTHEN (clever_rewrite_gen p - (mkApp (Lazy.force coq_Zs, [| mk_inj t |])) + (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) ((Lazy.force coq_inj_S),[t])) (loop (P_APP 1 :: p) t)) | _ -> explore p t @@ -1564,7 +1566,7 @@ let rec decidability gl t = | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> errorlabstrm "decidability" (str "Omega: Can't solve a goal with equality on " ++ - Printer.prterm typ) + 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 |]) @@ -1665,25 +1667,25 @@ let destructure_hyps gl = | Kapp(Zle, [t1;t2]) -> tclTHENLIST [ (generalize_tac - [mkApp (Lazy.force coq_not_Zle, [| t1;t2;mkVar i|])]); + [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_not_Zge, [| t1;t2;mkVar i|])]); + [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_not_Zlt, [| t1;t2;mkVar i|])]); + [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_not_Zgt, [| t1;t2;mkVar i|])]); + [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Le, [t1;t2]) -> @@ -1776,7 +1778,7 @@ let destructure_goal gl = let destructure_goal = all_time (destructure_goal) let omega_solver gl = - Library.check_required_library ["Coq";"omega";"Omega"]; + 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; *) diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4 index 726cf8bc..01592ebe 100644 --- a/contrib/omega/g_omega.ml4 +++ b/contrib/omega/g_omega.ml4 @@ -15,10 +15,10 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_omega.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: g_omega.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) open Coq_omega -TACTIC EXTEND Omega - [ "Omega" ] -> [ omega_solver ] +TACTIC EXTEND omega + [ "omega" ] -> [ omega_solver ] END diff --git a/contrib/omega/omega.ml b/contrib/omega/omega.ml index f0eb1e78..fd774c16 100755..100644 --- a/contrib/omega/omega.ml +++ b/contrib/omega/omega.ml @@ -11,52 +11,75 @@ (* *) (* 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. *) (**************************************************************************) -(* $Id: omega.ml,v 1.7.2.2 2005/02/17 18:25:20 herbelin Exp $ *) - -open Util -open Hashtbl open Names -let flat_map f = - let rec flat_map_f = function - | [] -> [] - | x :: l -> f x @ flat_map_f l - in - flat_map_f - -let pp i = print_int i; print_newline (); flush stdout +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 -let filter = List.partition +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 = 0 then x else pgcd y (x mod y) +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 >=0 , b > 0 with + match a >=? zero , b >? zero with | true,true -> a / b | false,false -> a / b - | true, false -> (a-1) / b - 1 - | false,true -> (a+1) / b - 1 + | true, false -> (a-one) / b - one + | false,true -> (a+one) / b - one -let new_id = - let cpt = ref 0 in fun () -> incr cpt; ! cpt - -let new_var = - let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt) - -let new_var_num = - let cpt = ref 1000 in (fun () -> incr cpt; !cpt) - -type coeff = {c: int ; v: int} +type coeff = {c: bigint ; v: int} type linear = coeff list @@ -70,60 +93,63 @@ type afine = { (* the variables and their coefficient *) body: coeff list; (* a constant *) - constant: int } + 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 * int * int - | NOT_EXACT_DIVIDE of afine * int + | DIVIDE_AND_APPROX of afine * afine * bigint * bigint + | NOT_EXACT_DIVIDE of afine * bigint | FORGET_C of int - | EXACT_DIVIDE of afine * int - | SUM of int * (int * afine) * (int * afine) - | STATE of afine * afine * afine * int * 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 * int + | MERGE_EQ of int * afine * int + | CONSTANT_NOT_NUL of int * bigint | CONSTANT_NUL of int - | CONSTANT_NEG of int * int + | CONSTANT_NEG of int * bigint | SPLIT_INEQ of afine * (int * action list) * (int * action list) - | WEAKEN of int * int + | WEAKEN of int * bigint exception UNSOLVABLE exception NO_CONTRADICTION -let intern_id,unintern_id = - let cpt = ref 0 in - let table = create 7 and co_table = create 7 in - (fun (name : identifier) -> - try find table name with Not_found -> - let idx = !cpt in - add table name idx; add co_table idx name; incr cpt; idx), - (fun idx -> - try find co_table idx with Not_found -> - let v = new_var () in add table v idx; add co_table idx v; v) - -let display_eq (l,e) = +let display_eq print_var (l,e) = let _ = List.fold_left (fun not_first f -> print_string - (if f.c < 0 then "- " else if not_first then "+ " else ""); + (if f.c <? zero then "- " else if not_first then "+ " else ""); let c = abs f.c in - if c = 1 then - Printf.printf "%s " (string_of_id (unintern_id f.v)) + if c =? one then + Printf.printf "%s " (print_var f.v) else - Printf.printf "%d %s " c (string_of_id (unintern_id f.v)); + Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); true) false l in - if e > 0 then - Printf.printf "+ %d " e - else if e < 0 then - Printf.printf "- %d " (abs e) + 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 -> ">=" @@ -131,49 +157,51 @@ let operator_of_eq = function let kind_of = function | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" -let display_system l = +let display_system print_var l = List.iter (fun { kind=b; body=e; constant=c; id=id} -> - print_int id; print_string ": "; - display_eq (e,c); print_string (operator_of_eq b); - print_string "0\n") + 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 l = - List.iter (fun e -> display_eq e;print_string ">= 0\n") l; +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 rec display_action = function +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 %d and the constant coefficient is \ - rounded by substracting %d.\n" e1.id k d + "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 \ - %d of its other coefficients.\n" e.id k + %s of its other coefficients.\n" e.id (sbi k) | EXACT_DIVIDE (e,k) -> Printf.printf "Equation E%d is divided by the pgcd \ - %d of its coefficients.\n" e.id k + %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 %d.\n" e k + 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 = %d %s E%d + %d %s E%d.\n" - (kind_of e1.kind) e c1 (kind_of e1.kind) e1.id c2 + "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 (e,_,_,x,_) -> - Printf.printf "We define a new equation %d :" e.id; - display_eq (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0\n" + | 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 %d :" e.id; - display_eq (e.body,e.constant); + 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 @@ -182,33 +210,34 @@ let rec display_action = function 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 implie a contradiction on their \ + "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 - "Eqations E%d and E%d state that their body is at the same time + "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 %d=0.\n" e k + Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) | CONSTANT_NEG(e,k) -> - Printf.printf "equation E%d states %d >= 0.\n" 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 + 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 l1; + 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 l2; + display_action print_var l2; print_newline () - end; display_action l + 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 [v]; push v accu), + (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu), (fun () -> !accu), (fun () -> accu := []) @@ -218,7 +247,7 @@ 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=0 then loop l else {v=x.v; c=c} :: loop l + | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l | [] -> [] in loop @@ -227,28 +256,28 @@ 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 -> -x) +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 = 0 then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 + 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 eq1 eq2 = - { kind = eq1.kind; id = new_id (); +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 = 1 then x,l else let (c',l') = chop_factor_1 l in (c',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 @@ -261,24 +290,24 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = if e = [] then begin match eq_flag with | EQUA -> - if x =0 then [] else begin + if x =? zero then [] else begin add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE end | DISE -> - if x <> 0 then [] else begin + if x <> zero then [] else begin add_event (CONSTANT_NUL id); raise UNSOLVABLE end | INEQ -> - if x >= 0 then [] else begin + 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 <> 0 then begin + 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 <> 0 then begin + end else if eq_flag=DISE & x mod gcd <> zero then begin add_event (FORGET_C eq.id); [] - end else if gcd <> 1 then begin + 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; @@ -288,97 +317,107 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = [new_eq] end else [eq] -let eliminate_with_in {v=v;c=c_unite} eq2 +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=1 then -f.c else if c_unite= -1 then f.c + 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 eq1 (map_eq_afine (fun c -> c * coeff) eq2) in - add_event (SUM (res.id,(1,eq1),(coeff,eq2))); res + 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 (2 * a + b) (2 * b) -let banerjee_step original l1 l2 = +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_num () 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)) + 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 [original] ; failwith "TL" in - let m = smallest + 1 in + 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= -m;v=sigma} :: + body = {c= neg m;v=sigma} :: map_eq_linear (fun a -> omega_mod a m) original.body; - id = new_id (); kind = EQUA } in + id = new_eq_id (); kind = EQUA } in let definition = - { constant = - floor_div (2 * original.constant + m) (2 * m); - body = map_eq_linear (fun a -> - floor_div (2 * a + m) (2 * m)) + { 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_id (); kind = EQUA } in - add_event (STATE (new_eq,definition,original,m,sigma)); + 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 = - flat_map (fun e -> normalize (eliminate_with_in eliminated_var new_eq e)) - l1 in + Util.list_map_append + (fun e -> + normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in let inequations = - flat_map (fun e -> normalize (eliminate_with_in eliminated_var new_eq e)) - l2 in - let original' = eliminate_with_in eliminated_var new_eq original in + 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 (e,other,ineqs) = - if !debug then display_system (e::other); +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 - (flat_map (fun e' -> normalize (eliminate_with_in v e e')) other, - flat_map (fun e' -> normalize (eliminate_with_in v e e')) ineqs) - with FACTOR1 -> eliminate_one_equation (banerjee_step e other ineqs) - -let rec banerjee (sys_eq,sys_ineq) = + (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 = 1) eq.body then 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 sys_ineq; sys_ineq + [] -> 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 = 0 then begin - add_event (FORGET_C eq.id); banerjee (other,sys_ineq) + 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 (eliminate_one_equation (eq,other,sys_ineq)) + else + banerjee new_ids + (eliminate_one_equation new_ids (eq,other,sys_ineq)) + type kind = INVERTED | NORMAL -let redundancy_elimination system = + +let redundancy_elimination new_eq_id system = let normal = function - ({body=f::_} as e) when f.c < 0 -> negate_eq e, INVERTED + ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED | e -> e,NORMAL in - let table = create 7 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 < 0 then begin + 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) = find table ne in + 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 + 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) @@ -386,32 +425,32 @@ let redundancy_elimination system = end else begin match optinvert with Some v -> - let kept = - if v.constant > nx.constant + 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)) + (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 + if high.constant <? low.constant then begin add_event(CONTRADICTION (high,negate_eq low)); raise UNSOLVABLE end | _ -> () end; - remove table ne; - add table ne final + Hashtbl.remove table ne; + Hashtbl.add table ne final with Not_found -> - add table ne + 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 - iter + Hashtbl.iter (fun p0 p1 -> match (p0,p1) with - | (e, (Some x, Some y)) when x.constant = y.constant -> - let id=new_id () in + | (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)) -> @@ -425,17 +464,17 @@ let redundancy_elimination system = exception SOLVED_SYSTEM let select_variable system = - let table = create 7 in + let table = Hashtbl.create 7 in let push v c= - try let r = find table v in r := max !r (abs c) - with Not_found -> add table v (ref (abs c)) in + 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 0 in + let vmin,cmin = ref (-1), ref zero in let var_cpt = ref 0 in - iter + Hashtbl.iter (fun v ({contents = c}) -> incr var_cpt; - if c < !cmin or !vmin = (-1) then begin vmin := v; cmin := c end) + if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end) table; if !var_cpt < 1 then raise SOLVED_SYSTEM; !vmin @@ -444,25 +483,25 @@ 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 >= 0 then (not_occ,((f.c,eq) :: below),over) - else (not_occ,below,((-f.c,eq) :: over)) + 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 dark_shadow low high = +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 (map_eq_afine (fun c -> c * b) eq1) + 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 - 1) * (b - 1) in + 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} @@ -473,33 +512,34 @@ let product dark_shadow low high = accu high) [] low -let fourier_motzkin dark_shadow system = +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 dark_shadow ineq_low ineq_high in - if !debug then display_system expanded; expanded + 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 dark_shadow system = +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 = flat_map normalize system in - let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in - let simp_eq,simp_ineq = redundancy_elimination ineqs in + 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 system in + let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = - let simp_eq,simp_ineq = redundancy_elimination sys_ineq in + 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 dark_shadow system in + let expanded = fourier_motzkin new_ids dark_shadow system in loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system system; system + with SOLVED_SYSTEM -> + if !debug then display_system print_var system; system in loop2 (loop1a system) @@ -520,11 +560,9 @@ let rec depend relie_on accu = function depend (e1.id::e2.id::relie_on) (act::accu) l else depend relie_on accu l - | STATE (e,_,o,_,_) -> - if List.mem e.id relie_on then - depend (o.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 @@ -548,59 +586,68 @@ let rec depend relie_on accu = function end | [] -> relie_on, accu -let solve system = - try let _ = simplify false system in failwith "no contradiction" - with UNSOLVABLE -> display_action (snd (depend [] [] (history ()))) +(* +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,_ = filter (fun e -> e.kind = DISE) ineqs in + let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function - | ({body=f::_} as e) when f.c < 0 -> negate_eq e, INVERTED + | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED | e -> e,NORMAL in - let table = create 7 in + let table = Hashtbl.create 7 in List.iter (fun e -> let {body=ne;constant=c} ,kind = normal e in - add table (ne,c) (kind,e)) diseq; + Hashtbl.add table (ne,c) (kind,e)) diseq; List.iter (fun e -> - if e.kind <> EQUA then pp 9999; + assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in try - let (kind',e') = find table (ne,c) in + 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 system = +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 system in + let sys_ineq = banerjee new_ids system in loop1b sys_ineq and loop1b sys_ineq = - let dise,ine = filter (fun e -> e.kind = DISE) sys_ineq in - let simp_eq,simp_ineq = redundancy_elimination ine in + 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 false system in + let expanded = fourier_motzkin new_ids false system in loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system system; system + 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_id () - and id2 = new_id () in + let id1 = new_eq_id () + and id2 = new_eq_id () in let e1 = - {id = id1; kind=INEQ; body = de.body; constant = de.constant - 1} in + {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in let e2 = - {id = id2; kind=INEQ; body = map_eq_linear (fun x -> -x) de.body; - constant = - de.constant - 1} in + {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 @ @@ -611,13 +658,13 @@ let simplify_strong system = | ([],ineqs,expl_map) -> ineqs,expl_map in try - let system = flat_map normalize system in - let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in - let dise,ine = filter (fun e -> e.kind = DISE) ineqs in - let simp_eq,simp_ineq = redundancy_elimination ine in + 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 = filter (fun e -> e.kind = DISE) 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 = @@ -627,20 +674,21 @@ let simplify_strong system = try let _ = loop2 sys in raise NO_CONTRADICTION with UNSOLVABLE -> let relie_on,path = depend [] [] (history ()) in - let dc,_ = filter (fun (_,id,_) -> List.mem id relie_on) decomp 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 = create 7 in + let tbl = Hashtbl.create 7 in let augment x = - try incr (find tbl x) with Not_found -> add tbl x (ref 1) in + 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; - iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; + Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; !eq in let rec solve systems = @@ -649,17 +697,20 @@ let simplify_strong system = let rec sign = function | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in - let s1,s2 = filter (fun (_,_,decomp,_) -> sign decomp) systems in + let s1,s2 = + List.partition (fun (_,_,decomp,_) -> sign decomp) systems in let s1' = - List.map (fun (dep,ro,dc,pa) -> (list_except id dep,ro,dc,pa)) s1 in + 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) -> (list_except id dep,ro,dc,pa)) s2 in + 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 :: list_union relie1 relie2 + [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/recdef/Recdef.v b/contrib/recdef/Recdef.v new file mode 100644 index 00000000..2d206220 --- /dev/null +++ b/contrib/recdef/Recdef.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* 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/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4 new file mode 100644 index 00000000..353fcdb3 --- /dev/null +++ b/contrib/recdef/recdef.ml4 @@ -0,0 +1,1263 @@ +(************************************************************************) +(* 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 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 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 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 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 Options.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: + constr -> constr -> (constr list ->constr)*(constr list list)) = + fun 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 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 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(_) -> error "find_call_occs : Rel" + | Var(id) -> (fun l -> expr), [] + | Meta(_) -> error "find_call_occs : Meta" + | Evar(_) -> error "find_call_occs : Evar" + | Sort(_) -> error "find_call_occs : Sort" + | Cast(b,_,_) -> find_call_occs f b + | Prod(_,_,_) -> error "find_call_occs : Prod" + | Lambda(_,_,_) -> error "find_call_occs : Lambda" + | LetIn(_,_,_,_) -> error "find_call_occs : let in" + | Const(_) -> (fun l -> expr), [] + | Ind(_) -> (fun l -> expr), [] + | Construct (_, _) -> (fun l -> expr), [] + | Case(i,t,a,r) -> + (match find_call_occs f a with + cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) + | _ -> (fun l -> mkCase(i, t, a, r)),[]) + | 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_reference + (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_reference (delayed_force iter_ref)) +let max_constr = function () -> (constr_of_reference (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") + +let mkCaseEq a : tactic = + (fun g -> + (* commentaire de Yves: on pourra avoir des problemes si + a n'est pas bien type dans l'environnement du but *) + let type_of_a = pf_type_of g a in + (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]) + (tclTHEN + (fun g2 -> + change_in_concl None + (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2)) + g2) + (simplest_case a))) g);; + +let rec mk_intros_and_continue (extra_eqn:bool) + cont_function (eqs:constr list) (expr:constr) g = + 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 extra_eqn cont_function eqs + (subst1 (mkVar new_n) b)) g + | _ -> + if extra_eqn then + let teq = pf_get_new_id teq_id g in + tclTHENLIST + [ h_intro teq; + tclMAP + (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) + (List.rev eqs); + (fun g1 -> + let ty_teq = pf_type_of g1 (mkVar teq) in + let teq_lhs,teq_rhs = + let _,args = destApp ty_teq in + args.(1),args.(2) + in + cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 + ) + ] + g + else + cont_function eqs expr g + +let const_of_ref = function + ConstRef kn -> kn + | _ -> anomaly "ConstRef expected" + +let simpl_iter () = + reduce + (Lazy + {rBeta=true;rIota=true;rZeta= true; rDelta=false; + rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) + onConcl + +(* The boolean value is_mes expresses that the termination is expressed + using a measure function instead of a well-founded relation. *) +let tclUSER 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 unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] + else tclIDTAC + ] + 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(); + 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 + (apply_with_bindings + (delayed_force le_trans, + ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"),a])) + [compute_le_proofs tl; + tclORELSE (apply (delayed_force le_n)) assumption]) + +let make_lt_proof pmax le_proof = + tclTHENS + (apply_with_bindings + (delayed_force le_lt_trans, + ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"), pmax])) + [compute_le_proofs le_proof; + tclTHENLIST[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 -> + tclTHENS + (general_rewrite_bindings false + (mkVar eq, + ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; + dummy_loc, NamedHyp def_id, mkVar def])) + [list_cond_rewrite k def pmax eqs le_proofs; + 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()); + observe_tac "unfold functional" + (unfold_in_concl[([1],evaluable_of_global_reference func)]); + observe_tac "rewriting equations" + (list_rewrite true eqs); + observe_tac "cond rewrite" (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 = + 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 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 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))) + [ observe_tac "h_assumption" h_assumption + ; + tclTHENLIST + [ + tclTRY(list_rewrite true eqs); + observe_tac "user proof" + (fun g -> + tclUSER + is_mes + (Some (hrec::hspec::(retrieve_acc_var g)@specs)) + g + ) + ] + ] + ) + ]) g) + + ) + + +let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr = + match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with + | context_fn, args -> + observe_tac "introduce_all_values" + (introduce_all_values is_mes acc_inv func context_fn eqs hrec args [] []) + +let proveterminate 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 (_, t, a, l) -> + (match find_call_occs f_constr a with + _,[] -> + tclTHENS + (fun g -> + (* let _ = msgnl(str "entering mkCaseEq") in *) + let v = (mkCaseEq a) g in + (* let _ = msgnl (str "exiting mkCaseEq") in *) + v + ) + (List.map + (mk_intros_and_continue true proveterminate eqs) + (Array.to_list l) + ) + | _, _::_ -> + ( + match find_call_occs 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 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 + (* let _ = msgnl(str "exiting proveterminate") in *) + v + with e -> + begin + msgerrnl(str "failure in proveterminate"); + raise e + end + in + proveterminate + +let hyp_terminates func = + let a_arrow_b = arg_type (constr_of_reference func) in + let rev_args,b = decompose_prod a_arrow_b in + let left = + mkApp(delayed_force iter, + Array.of_list + (lift 5 a_arrow_b:: mkRel 3:: + constr_of_reference 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 is_mes names_to_suppress = + if is_mes + then + tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings)) + else tclUSER 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 + true (* the assert thm is in first subgoal *) + (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 + true + (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_apply ((mkApp(mkVar wf_thm, + [|mkVar rec_arg_id |])),Rawterm.NoBindings) + ) + ] + ; + (* rest of the proof *) + tclTHENSEQ + [observe_tac "generalize" + (onNLastHyps (nargs+1) + (fun (id,_,_) -> + tclTHEN (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 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 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_reference 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 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 hrec acc_inv g -> + (proveterminate + is_mes + acc_inv + hrec + (mkVar f_id) + func + base_leaf_terminate + rec_leaf_terminate + [] + expr + ) + g + ) + tclUSER_if_not_mes + 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_reference 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 + [ + 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 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 lemma = mkConst (Lib.make_con na) in + Array.iteri + (fun i _ -> + by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i))) + (Array.make nb_goal ()) + ; + ref := Some lemma ; + defined (); + 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_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); + tclCOMPLETE Auto.default_auto + ] + ) + using_lemmas) + ) tclIDTAC) + g); + try + by tclIDTAC; (* raises UserError _ if the proof is complete *) + if Options.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 hook = + let (evmap, env) = Command.get_current_context() in + start_proof thm_name + (Global, Proof Lemma) (Environ.named_context_val env) + (hyp_terminates fonctional_ref) hook; + by (observe_tac "whole_start" (whole_start is_mes fonctional_ref + input_type relation rec_arg_num )); + try + let new_goal_type = build_new_goal_type () in + open_new_goal 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,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, 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 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_reference term_f in + let nargs = nb_prod (type_of_const terminate_constr) in + let x = + let rec f ids n = + if n = 0 + then [] + else + let x = next_global_ident_away true x_id ids in + x::f (x::ids) (n-1) + in + f ids nargs + in + tclTHENLIST [ + h_intros x; + observe_tac "unfold_constr f" (unfold_constr 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(); + unfold_in_concl [([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 + [] -> + tclTHENLIST + [tclTHENS + (general_rewrite_bindings false + (mkVar heq1, + ExplicitBindings[dummy_loc,NamedHyp k_id, + f_S(f_S(mkVar pmax)); + dummy_loc,NamedHyp def_id, + f])) + [tclTHENLIST + [simpl_iter(); + unfold_constr (reference_of_constr functional); + 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]; + rewriteLR (mkVar heq2); + tclTHENS + (general_rewrite_bindings false + (mkVar heq, + ExplicitBindings + [dummy_loc, NamedHyp k_id, + f_S(mkVar pmax'); + dummy_loc, NamedHyp def_id, f])) + [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 + [h_intros [v;hex]; + simplest_elim (mkVar hex); + h_intros [p;heq1]; + generalize [mkApp(delayed_force le_n,[|mkVar p|])]; + h_intros [hle1]; + introduce_all_values_eq + (fun _ _ -> tclIDTAC) + functional termine f p heq1 p [] [] eqs ids args; + 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(_,t,a,l) -> + (match find_call_occs f a with + _,[] -> + tclTHENS(mkCaseEq a)(* (simplest_case a) *) + (List.map + (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true + (prove_eq termine f functional) eqs expr)) + (Array.to_list l)) + | _,_::_ -> + (match find_call_occs 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_reference functional) + eqs expr fn args g)) + | _ -> + (match find_call_occs 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_reference 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 (evmap, env) = Command.get_current_context() in + let f_constr = (constr_of_reference 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_reference terminate_ref) + f_constr + functional_ref + [] + (instantiate_lambda + (def_of_const (constr_of_reference functional_ref)) + (f_constr::List.map mkVar x) + ) + ) + ); + Options.silently defined (); + );; + + +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 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"; *) + 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 anomalylabstrm "" (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); + anomaly "Cannot create equation Lemma" + end + end; + let eq_ref = Nametab.locate (make_short_qualid equation_id ) in + let f_ref = destConst (constr_of_reference f_ref) + and functional_ref = destConst (constr_of_reference functional_ref) + and eq_ref = destConst (constr_of_reference 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 Options.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 + hook + with e -> + begin + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); +(* anomaly "Cannot create termination Lemma" *) + raise e + end + + +VERNAC COMMAND EXTEND RecursiveDefinition + [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) + constr(proof) integer_opt(rec_arg_num) constr(eq) ] -> + [ + warning "Recursive Definition is obsolete. Use Function instead"; + ignore(proof);ignore(wf); + let rec_arg_num = + match rec_arg_num with + | None -> 1 + | Some n -> n + in + recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ()) []] +| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) + "[" ne_constr_list(proof) "]" constr(eq) ] -> + [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ()) []] +END + + + diff --git a/contrib/ring/ArithRing.v b/contrib/ring/LegacyArithRing.v index 1a6e0ba6..e062b731 100644 --- a/contrib/ring/ArithRing.v +++ b/contrib/ring/LegacyArithRing.v @@ -6,17 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ArithRing.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) (* Instantiation of the Ring tactic for the naturals of Arith $*) -Require Export Ring. +Require Import Bool. +Require Export LegacyRing. Require Export Arith. Require Import Eqdep_dec. Open Local Scope nat_scope. -Fixpoint nateq (n m:nat) {struct m} : bool := +Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := match n, m with | O, O => true | S n', S m' => nateq n' m' @@ -32,16 +33,16 @@ Proof. trivial. Qed. -Hint Resolve nateq_prop eq2eqT: arithring. +Hint Resolve nateq_prop: arithring. Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq. split; intros; auto with arith arithring. - apply eq2eqT; apply (fun n m p:nat => plus_reg_l m p n) with (n := n). - apply eqT2eq; trivial. +(* apply (fun n m p:nat => plus_reg_l m p n) with (n := n). + trivial.*) Defined. -Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. +Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. Goal forall n:nat, S n = 1 + n. intro; reflexivity. @@ -86,4 +87,4 @@ Ltac rewrite_S_to_plus := change (t1 = t2) in |- * end. -Ltac ring_nat := rewrite_S_to_plus; ring.
\ No newline at end of file +Ltac ring_nat := rewrite_S_to_plus; ring. diff --git a/contrib/ring/NArithRing.v b/contrib/ring/LegacyNArithRing.v index cfec29ce..c689fc40 100644 --- a/contrib/ring/NArithRing.v +++ b/contrib/ring/LegacyNArithRing.v @@ -6,16 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) (* Instantiation of the Ring tactic for the binary natural numbers *) -Require Export Ring. +Require Import Bool. +Require Export LegacyRing. Require Export ZArith_base. Require Import NArith. Require Import Eqdep_dec. -Definition Neq (n m:N) := +Unboxed Definition Neq (n m:N) := match (n ?= m)%N with | Datatypes.Eq => true | _ => false @@ -37,8 +38,9 @@ Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. apply Nmult_1_l. apply Nmult_0_l. apply Nmult_plus_distr_r. - apply Nplus_reg_l. +(* apply Nplus_reg_l.*) apply Neq_prop. Qed. -Add Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
\ No newline at end of file +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/Ring.v b/contrib/ring/LegacyRing.v index 81497533..dc8635bd 100644 --- a/contrib/ring/Ring.v +++ b/contrib/ring/LegacyRing.v @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Bool. -Require Export Ring_theory. +Require Export LegacyRing_theory. Require Export Quote. Require Export Ring_normalize. Require Export Ring_abstract. @@ -32,5 +32,5 @@ destruct n; destruct m; destruct p; reflexivity. destruct x; destruct y; reflexivity || simpl in |- *; tauto. Defined. -Add Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory - [ true false ].
\ No newline at end of file +Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory + [ true false ]. diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/LegacyRing_theory.v index dfdfdf66..5df927a6 100644 --- a/contrib/ring/Ring_theory.v +++ b/contrib/ring/LegacyRing_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_theory.v,v 1.21.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *) Require Export Bool. @@ -39,7 +39,7 @@ Record Semi_Ring_Theory : Prop := 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_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. @@ -52,10 +52,10 @@ 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. +(*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. + 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 *) @@ -126,11 +126,11 @@ 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. @@ -320,7 +320,7 @@ 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. @@ -336,7 +336,7 @@ 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). @@ -349,7 +349,7 @@ Qed. End Theory_of_rings. -Hint Resolve Th_mult_zero_left Th_plus_reg_left: core. +Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. Unset Implicit Arguments. @@ -373,4 +373,4 @@ End product_ring. Section power_ring. -End power_ring.
\ No newline at end of file +End power_ring. diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/LegacyZArithRing.v index c511c076..a410fbc5 100644 --- a/contrib/ring/ZArithRing.v +++ b/contrib/ring/LegacyZArithRing.v @@ -6,15 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *) (* Instantiation of the Ring tactic for the binary integers of ZArith *) -Require Export ArithRing. +Require Export LegacyArithRing. Require Export ZArith_base. Require Import Eqdep_dec. +Require Import LegacyRing. -Definition Zeq (x y:Z) := +Unboxed Definition Zeq (x y:Z) := match (x ?= y)%Z with | Datatypes.Eq => true | _ => false @@ -27,10 +28,10 @@ Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. Qed. Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. - split; intros; apply eq2eqT; eauto with zarith. - apply eqT2eq; apply Zeq_prop; assumption. + split; intros; eauto with zarith. + apply Zeq_prop; assumption. Qed. (* NatConstants and NatTheory are defined in Ring_theory.v *) -Add Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory - [ Zpos Zneg 0%Z xO xI 1%positive ].
\ No newline at end of file +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 index b4ac5745..6f7414a3 100644 --- a/contrib/ring/Quote.v +++ b/contrib/ring/Quote.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Quote.v,v 1.7.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Quote.v 6295 2004-11-12 16:40:39Z gregoire $ *) (*********************************************************************** The "abstract" type index is defined to represent variables. @@ -26,6 +26,7 @@ ***********************************************************************) Set Implicit Arguments. +Unset Boxed Definitions. Section variables_map. @@ -81,4 +82,4 @@ Qed. End variables_map. -Unset Implicit Arguments.
\ No newline at end of file +Unset Implicit Arguments. diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v index de42e8c3..115ed5ca 100644 --- a/contrib/ring/Ring_abstract.v +++ b/contrib/ring/Ring_abstract.v @@ -6,12 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_abstract.v,v 1.13.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *) -Require Import Ring_theory. +Require Import LegacyRing_theory. Require Import Quote. Require Import Ring_normalize. +Unset Boxed Definitions. + Section abstract_semi_rings. Inductive aspolynomial : Type := @@ -127,7 +129,7 @@ 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_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). @@ -138,7 +140,7 @@ 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 (SR_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. @@ -437,7 +439,7 @@ 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_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). @@ -447,7 +449,7 @@ 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 (Th_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. @@ -701,4 +703,4 @@ Proof. rewrite H; reflexivity. Qed. -End abstract_rings.
\ No newline at end of file +End abstract_rings. diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v index 8c0fd5fb..4a082396 100644 --- a/contrib/ring/Ring_normalize.v +++ b/contrib/ring/Ring_normalize.v @@ -6,12 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_normalize.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *) -Require Import Ring_theory. +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. @@ -355,7 +356,7 @@ 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_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). @@ -366,7 +367,7 @@ 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 (SR_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (* Hints Resolve refl_eqT sym_eqT trans_eqT. *) Hint Immediate T. @@ -784,7 +785,7 @@ 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_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). @@ -795,7 +796,7 @@ 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 (Th_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. @@ -898,4 +899,4 @@ Infix "*" := Pmult : ring_scope. Notation "- x" := (Popp x) : ring_scope. Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope. -Delimit Scope ring_scope with ring.
\ No newline at end of file +Delimit Scope ring_scope with ring. diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v index c4537fe3..7bf33b17 100644 --- a/contrib/ring/Setoid_ring.v +++ b/contrib/ring/Setoid_ring.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring.v,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Setoid_ring.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Setoid_ring_theory. Require Export Quote. diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v index 0c9c1e6a..56329ade 100644 --- a/contrib/ring/Setoid_ring_normalize.v +++ b/contrib/ring/Setoid_ring_normalize.v @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_normalize.v,v 1.11.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Setoid_ring_normalize.v 6662 2005-02-02 21:33:14Z sacerdot $ *) 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 |- *; @@ -34,24 +35,24 @@ Variable Aeq : A -> A -> bool. Variable S : Setoid_Theory A Aequiv. -Add Setoid A Aequiv S. +Add Setoid A Aequiv S as Asetoid. -Variable - plus_morph : - forall a a0 a1 a2:A, - Aequiv a a0 -> Aequiv a1 a2 -> Aequiv (Aplus a a1) (Aplus a0 a2). -Variable - mult_morph : - forall a a0 a1 a2:A, - Aequiv a a0 -> Aequiv a1 a2 -> Aequiv (Amult a a1) (Amult a0 a2). +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. -exact plus_morph. +intros; apply plus_morph; assumption. Qed. Add Morphism Amult : Amult_ext. -exact mult_morph. +intros; apply mult_morph; assumption. Qed. Add Morphism Aopp : Aopp_ext. @@ -488,19 +489,22 @@ 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))). + (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)))). + (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)))). + (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0)))); + [ idtac | trivial ]. auto. elim (varlist_lt v v0); simpl in |- *. @@ -550,19 +554,23 @@ 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))). + (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)))). + (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)))). -setoid_replace (Amult Aone (interp_vl v0)) with (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 |- *. @@ -613,18 +621,21 @@ rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c 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))); - 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)))); - 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 ]. +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. @@ -668,17 +679,20 @@ rewrite 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))); - 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)))); - 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 + (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 |- *. @@ -727,7 +741,8 @@ 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))). + (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))); + [ idtac | trivial ]. auto. elim (varlist_lt l v); simpl in |- *; intros. @@ -746,8 +761,10 @@ 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))). -setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v). + (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. @@ -769,7 +786,8 @@ 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))). + (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. @@ -784,7 +802,8 @@ 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))). + (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. @@ -806,7 +825,8 @@ rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a 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))). + 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)); @@ -829,7 +849,8 @@ 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))). + (Amult (interp_vl l) (interp_setcs c))); + [ idtac | trivial ]. auto. rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)). @@ -858,15 +879,18 @@ 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))). + (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)))). + (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)))). + (Amult c (Amult a (Amult (interp_vl l) (interp_vl v)))); + [ idtac | trivial ]. auto. rewrite @@ -880,7 +904,8 @@ setoid_replace (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)))). + (Amult (interp_vl l) (interp_setcs c0)))); + [ idtac | trivial ]. auto. Qed. @@ -900,12 +925,14 @@ 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)). + (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))). + (Amult (interp_setcs c) (interp_setcs y))); + [ idtac | trivial ]. trivial. rewrite @@ -947,7 +974,8 @@ 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. +setoid_replace (Amult Azero (interp_vl v)) with Azero; + [ idtac | trivial ]. rewrite H. trivial. @@ -1134,4 +1162,4 @@ Qed. End setoid_rings. -End setoid.
\ No newline at end of file +End setoid. diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v index 69712216..ae6610d3 100644 --- a/contrib/ring/Setoid_ring_theory.v +++ b/contrib/ring/Setoid_ring_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_theory.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: Setoid_ring_theory.v 6662 2005-02-02 21:33:14Z sacerdot $ *) Require Export Bool. Require Export Setoid. @@ -22,7 +22,7 @@ Infix Local "==" := Aequiv (at level 70, no associativity). Variable S : Setoid_Theory A Aequiv. -Add Setoid A Aequiv S. +Add Setoid A Aequiv S as Asetoid. Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. @@ -37,18 +37,18 @@ Notation "0" := Azero. Notation "1" := Aone. Notation "- x" := (Aopp x). -Variable - plus_morph : forall a a0 a1 a2:A, a == a0 -> a1 == a2 -> a + a1 == a0 + a2. -Variable - mult_morph : forall a a0 a1 a2:A, a == a0 -> a1 == a2 -> a * a1 == a0 * a2. +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. -exact plus_morph. +intros; apply plus_morph; assumption. Qed. Add Morphism Amult : Amult_ext. -exact mult_morph. +intros; apply mult_morph; assumption. Qed. Add Morphism Aopp : Aopp_ext. @@ -424,4 +424,4 @@ Section power_ring. End power_ring. -End Setoid_rings.
\ No newline at end of file +End Setoid_rings. diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4 index af23a8f7..d0058026 100644 --- a/contrib/ring/g_quote.ml4 +++ b/contrib/ring/g_quote.ml4 @@ -8,11 +8,11 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_quote.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $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 ] +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 index f7c74c0b..2f964988 100644 --- a/contrib/ring/g_ring.ml4 +++ b/contrib/ring/g_ring.ml4 @@ -8,13 +8,14 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ring.ml4,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *) +(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *) open Quote open Ring +open Tacticals -TACTIC EXTEND Ring - [ "Ring" constr_list(l) ] -> [ polynom l ] +TACTIC EXTEND ring +| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ] END (* The vernac commands "Add Ring" and co *) @@ -23,7 +24,7 @@ let cset_of_constrarg_list l = List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty VERNAC COMMAND EXTEND AddRing - [ "Add" "Ring" + [ "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 @@ -40,7 +41,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Semi" "Ring" +| [ "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 @@ -57,7 +58,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Abstract" "Ring" +| [ "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 @@ -74,7 +75,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Abstract" "Semi" "Ring" +| [ "Add" "Legacy" "Abstract" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(t) ] -> [ add_theory false true false @@ -91,7 +92,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Setoid" "Ring" +| [ "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) "]" ] @@ -112,7 +113,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Semi" "Setoid" "Ring" +| [ "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) "]" ] diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index bda04db3..e0a6cba3 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: quote.ml,v 1.30.2.1 2004/07/16 19:30:14 herbelin Exp $ *) +(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *) (* The `Quote' tactic *) @@ -107,7 +107,6 @@ open Pp open Util open Names open Term -open Instantiate open Pattern open Matching open Tacmach @@ -213,7 +212,7 @@ let compute_rhs bodyi index_of_f = PMeta (Some (coerce_meta_in i)) | App (f,args) -> PApp (pattern_of_constr f, Array.map aux args) - | Cast (c,t) -> aux c + | Cast (c,_,_) -> aux c | _ -> pattern_of_constr c in aux bodyi @@ -298,8 +297,8 @@ binary search trees (see file \texttt{Quote.v}) *) 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 + | 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 @@ -361,7 +360,7 @@ 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') + | Cast(t,_,_) -> (subterm gl t t') | _ -> false) (*s We want to sort the list according to reverse subterm order. *) @@ -386,7 +385,7 @@ let rec sort_subterm gl l = [gl: goal sigma]\\ *) let quote_terms ivs lc gl = - Library.check_required_library ["Coq";"ring";"Quote"]; + 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 *) @@ -448,8 +447,8 @@ let quote f lid gl = | _ -> assert false in match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) gl - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) gl + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl (*i diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 378f19a4..6b82b75b 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml,v 1.49.2.1 2004/07/16 19:30:14 herbelin Exp $ *) +(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *) (* ML part of the Ring tactic *) @@ -34,6 +34,7 @@ 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 @@ -42,7 +43,7 @@ let ring_dir = ["Coq";"ring"] let setoids_dir = ["Coq";"Setoids"] let ring_constant = Coqlib.gen_constant_in_modules "Ring" - [ring_dir@["Ring_theory"]; + [ring_dir@["LegacyRing_theory"]; ring_dir@["Setoid_ring_theory"]; ring_dir@["Ring_normalize"]; ring_dir@["Ring_abstract"]; @@ -286,7 +287,7 @@ let guess_theory a = with Not_found -> errorlabstrm "Ring" (str "No Declared Ring Theory for " ++ - prterm a ++ fnl () ++ + pr_lconstr a ++ fnl () ++ str "Use Add [Semi] Ring to declare it") (* Looks up an option *) @@ -306,23 +307,42 @@ let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false 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 = + 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 " ++ - prterm a); + pr_lconstr a); let env = Global.env () in - if (want_ring & want_setoid & + 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) |])) then + [| 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 & + if (not want_ring & want_setoid & ( not (implement_theory env t coq_Semi_Setoid_Ring_Theory - [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) & + [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || not (implement_theory env (unbox asetth) coq_Setoid_Theory - [| a; (unbox aequiv) |])) then + [| 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 @@ -705,10 +725,10 @@ let build_setspolynom gl th lc = 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; v; - th.th_t; (unbox th.th_setoid_th); + 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; p |]))) + (unbox th.th_morph).multm; v; th.th_t; p |]))) lp module SectionPathSet = @@ -724,7 +744,7 @@ let constants_to_unfold = let transform s = let sp = path_of_string s in let dir, id = repr_path sp in - Libnames.encode_kn dir id + Libnames.encode_con dir id in List.map transform [ "Coq.ring.Ring_normalize.interp_cs"; @@ -753,7 +773,7 @@ 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) + reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) let polynom_unfold_tac_in_term gl = let flags = @@ -804,20 +824,22 @@ let raw_polynom th op lc gl = [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th); c'''i; ci; c'i_eq_c''i |])))) - (tclTHEN - (Setoid_replace.setoid_replace ci c'''i None) - (tclTHEN - (tclTRY (h_exact c'i_eq_c''i)) - tac))) + (tclTHENS + (tclORELSE + (Setoid_replace.general_s_rewrite true c'i_eq_c''i + ~new_goals:[]) + (Setoid_replace.general_s_rewrite false c'i_eq_c''i + ~new_goals:[])) + [tac])) else (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) - (h_exact (mkApp(build_coq_sym_eqT (), + (h_exact (mkApp(build_coq_sym_eq (), [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (elim_type - (mkApp(build_coq_eqT (), [|th.th_a; c'''i; ci |]))) + (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) [ tac; h_exact c'i_eq_c''i ])) ) @@ -863,7 +885,7 @@ let match_with_equiv c = match (kind_of_term c) with | _ -> None let polynom lc gl = - Library.check_required_library ["Coq";"ring";"Ring"]; + 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, diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v index b3895b2a..19933873 100644 --- a/contrib/romega/ROmega.v +++ b/contrib/romega/ROmega.v @@ -6,6 +6,5 @@ *************************************************************************) -Require Import Omega. Require Import ReflOmegaCore. diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v index 3dfb5593..83ea5b63 100644 --- a/contrib/romega/ReflOmegaCore.v +++ b/contrib/romega/ReflOmegaCore.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (************************************************************************* PROJET RNRT Calife - 2001 @@ -9,9 +10,11 @@ Require Import Arith. Require Import List. Require Import Bool. -Require Import ZArith. +Require Import ZArith_base. Require Import OmegaLemmas. +Open Scope Z_scope. + (* \subsection{Definition of basic types} *) (* \subsubsection{Environment of propositions (lists) *) @@ -45,6 +48,18 @@ Inductive term : Set := | Topp : term -> term | Tvar : nat -> term. +Delimit Scope romega_scope with term. +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 1) : romega_scope. + (* \subsubsection{Definition of reified goals} *) (* Very restricted definition of handled predicates that should be extended to cover a wider set of operations. @@ -67,13 +82,13 @@ Inductive proposition : Set := | Tprop : nat -> proposition. (* Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition) (only parsing). +Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) -Notation lhyps := (list (list proposition)) (only parsing). +Notation lhyps := (list hyps). (* a syngle goal packed in a subgoal list *) -Notation singleton := (fun a : list proposition => a :: nil) (only parsing). +Notation singleton := (fun a : hyps => a :: nil). (* an absurd goal *) Definition absurd := FalseTerm :: nil. @@ -120,7 +135,7 @@ Inductive step : Set := | C_PLUS_ASSOC_R : step | C_PLUS_ASSOC_L : step | C_PLUS_PERMUTE : step - | C_PLUS_SYM : step + | C_PLUS_COMM : step | C_RED0 : step | C_RED1 : step | C_RED2 : step @@ -130,7 +145,7 @@ Inductive step : Set := | C_RED6 : step | C_MULT_ASSOC_REDUCED : step | C_MINUS : step - | C_MULT_SYM : step. + | C_MULT_COMM : step. (* \subsubsection{Omega steps} *) (* The following inductive type describes steps as they can be found in @@ -176,7 +191,7 @@ Inductive p_step : Set := type [p_step] permettant de parcourir à la fois les branches gauches et droit, on pourrait n'avoir qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont - utiles (sinon on ne les incluerait pas), on pourrait remplacer [h_step] + utiles (sinon on ne les inclurait pas), on pourrait remplacer [h_step] par une simple liste *) Inductive h_step : Set := @@ -360,29 +375,31 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | Tint st2 => eq_Z st1 st2 | _ => false end - | Tplus st11 st12 => + | (st11 + st12)%term => match t2 with - | Tplus st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | (st21 + st22)%term => eq_term st11 st21 && eq_term st12 st22 | _ => false end - | Tmult st11 st12 => + | (st11 * st12)%term => match t2 with - | Tmult st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | (st21 * st22)%term => eq_term st11 st21 && eq_term st12 st22 | _ => false end - | Tminus st11 st12 => + | (st11 - st12)%term => match t2 with - | Tminus st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | (st21 - st22)%term => eq_term st11 st21 && eq_term st12 st22 + | _ => false + end + | (- st1)%term => + match t2 with + | (- st2)%term => eq_term st1 st2 + | _ => false + end + | [st1]%term => + match t2 with + | [st2]%term => eq_nat st1 st2 | _ => false end - | Topp st1 => match t2 with - | Topp st2 => eq_term st1 st2 - | _ => false - end - | Tvar st1 => match t2 with - | Tvar st2 => eq_nat st1 st2 - | _ => false - end end. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. @@ -480,15 +497,15 @@ Ltac elim_eq_pos t1 t2 := avec son théorème *) Theorem relation_ind2 : - forall (P : Datatypes.comparison -> Prop) (b : Datatypes.comparison), - (b = Datatypes.Eq -> P Datatypes.Eq) -> - (b = Datatypes.Lt -> P Datatypes.Lt) -> - (b = Datatypes.Gt -> P Datatypes.Gt) -> P b. + forall (P : comparison -> Prop) (b : comparison), + (b = Eq -> P Eq) -> + (b = Lt -> P Lt) -> + (b = Gt -> P Gt) -> P b. simple induction b; auto. Qed. -Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2. +Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2) in |- *; apply relation_ind2. (* \subsection{Interprétations} \subsubsection{Interprétation des termes dans Z} *) @@ -496,11 +513,11 @@ Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2. Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z := match t with | Tint x => x - | Tplus t1 t2 => (interp_term env t1 + interp_term env t2)%Z - | Tmult t1 t2 => (interp_term env t1 * interp_term env t2)%Z - | Tminus t1 t2 => (interp_term env t1 - interp_term env t2)%Z - | Topp t => (- interp_term env t)%Z - | Tvar n => nth n env 0%Z + | (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} *) @@ -508,13 +525,13 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z) (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)%Z + | 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)%Z - | GtTerm t1 t2 => (interp_term env t1 > interp_term env t2)%Z - | LtTerm t1 t2 => (interp_term env t1 < interp_term env t2)%Z + | 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 => Zne (interp_term env t1) (interp_term env t2) | Tor p1 p2 => interp_proposition envp env p1 \/ interp_proposition envp env p2 @@ -531,7 +548,7 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z) à manipuler individuellement *) Fixpoint interp_hyps (envp : PropList) (env : list Z) - (l : list proposition) {struct l} : Prop := + (l : hyps) {struct l} : Prop := match l with | nil => True | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' @@ -542,26 +559,22 @@ Fixpoint interp_hyps (envp : PropList) (env : list Z) [Generalize] et qu'une conjonction est forcément lourde (répétition des types dans les conjonctions intermédiaires) *) -Fixpoint interp_goal_concl (envp : PropList) (env : list Z) - (c : proposition) (l : list proposition) {struct l} : Prop := +Fixpoint interp_goal_concl (c : proposition) (envp : PropList) + (env : list Z) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c | p' :: l' => - interp_proposition envp env p' -> interp_goal_concl envp env c l' + interp_proposition envp env p' -> interp_goal_concl c envp env l' end. -Notation interp_goal := - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) (only parsing). +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 : PropList) (env : list Z) (l : list proposition), - (interp_hyps envp env l -> False) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) envp env l. + forall (envp : PropList) (env : list Z) (l : hyps), + (interp_hyps envp env l -> False) -> interp_goal envp env l. simple induction l; [ simpl in |- *; auto @@ -569,10 +582,8 @@ simple induction l; Qed. Theorem hyps_to_goal : - forall (envp : PropList) (env : list Z) (l : list proposition), - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) envp env l -> - interp_hyps envp env l -> False. + forall (envp : PropList) (env : list Z) (l : hyps), + interp_goal envp env l -> interp_hyps envp env l -> False. simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. Qed. @@ -603,22 +614,16 @@ Definition valid2 (f : proposition -> proposition -> proposition) := liste de propositions et rend une nouvelle liste de proposition. On reste contravariant *) -Definition valid_hyps (f : list proposition -> list proposition) := - forall (ep : PropList) (e : list Z) (lp : list proposition), +Definition valid_hyps (f : hyps -> hyps) := + forall (ep : PropList) (e : list Z) (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 : PropList) (env : list Z) (l : list proposition) - (a : list proposition -> list proposition), - valid_hyps a -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env ( - a l) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env l. + forall (ep : PropList) (env : list Z) (l : hyps) (a : hyps -> hyps), + valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. intros; simpl in |- *; apply goal_to_hyps; intro H1; apply (hyps_to_goal ep env (a l) H0); apply H; assumption. @@ -627,25 +632,22 @@ Qed. (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) -Fixpoint interp_list_hyps (envp : PropList) (env : list Z) - (l : list (list proposition)) {struct l} : Prop := +Fixpoint interp_list_hyps (envp : PropList) (env : list Z) + (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 : PropList) (env : list Z) - (l : list (list proposition)) {struct l} : Prop := +Fixpoint interp_list_goal (envp : PropList) (env : list Z) + (l : lhyps) {struct l} : Prop := match l with | nil => True - | h :: l' => - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) envp env h /\ - interp_list_goal envp env l' + | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' end. Theorem list_goal_to_hyps : - forall (envp : PropList) (env : list Z) (l : list (list proposition)), + forall (envp : PropList) (env : list Z) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. simple induction l; simpl in |- *; @@ -656,7 +658,7 @@ simple induction l; simpl in |- *; Qed. Theorem list_hyps_to_goal : - forall (envp : PropList) (env : list Z) (l : list (list proposition)), + forall (envp : PropList) (env : list Z) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. simple induction l; simpl in |- *; @@ -665,21 +667,16 @@ simple induction l; simpl in |- *; [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. Qed. -Definition valid_list_hyps - (f : list proposition -> list (list proposition)) := - forall (ep : PropList) (e : list Z) (lp : list proposition), +Definition valid_list_hyps (f : hyps -> lhyps) := + forall (ep : PropList) (e : list Z) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). -Definition valid_list_goal - (f : list proposition -> list (list proposition)) := - forall (ep : PropList) (e : list Z) (lp : list proposition), - interp_list_goal ep e (f lp) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep e lp. +Definition valid_list_goal (f : hyps -> lhyps) := + forall (ep : PropList) (e : list Z) (lp : hyps), + interp_list_goal ep e (f lp) -> interp_goal ep e lp. Theorem goal_valid : - forall f : list proposition -> list (list proposition), - valid_list_hyps f -> valid_list_goal f. + forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. 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); @@ -687,7 +684,7 @@ unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; Qed. Theorem append_valid : - forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)), + forall (ep : PropList) (e : list Z) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). @@ -703,10 +700,10 @@ Qed. (* \subsubsection{Opérateurs valides sur les hypothèses} *) (* Extraire une hypothèse de la liste *) -Definition nth_hyps (n : nat) (l : list proposition) := nth n l TrueTerm. +Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. Theorem nth_valid : - forall (ep : PropList) (e : list Z) (i : nat) (l : list proposition), + forall (ep : PropList) (e : list Z) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). unfold nth_hyps in |- *; simple induction i; @@ -719,7 +716,7 @@ 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 : list proposition) := + (f : proposition -> proposition -> proposition) (l : hyps) := f (nth_hyps i l) (nth_hyps j l) :: l. Theorem apply_oper_2_valid : @@ -732,8 +729,8 @@ Qed. (* Modifier une hypothèse par application d'une opération valide *) -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) - (l : list proposition) {struct i} : list proposition := +Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) + (l : hyps) {struct i} : hyps := match l with | nil => nil (A:=proposition) | p :: l' => @@ -767,23 +764,23 @@ Qed. Definition apply_left (f : term -> term) (t : term) := match t with - | Tplus x y => Tplus (f x) y - | Tmult x y => Tmult (f x) y - | Topp x => Topp (f x) + | (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 - | Tplus x y => Tplus x (f y) - | Tmult x y => Tmult x (f y) + | (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 - | Tplus x y => Tplus (f x) (g y) - | Tmult x y => Tmult (f x) (g y) + | (x + y)%term => (f x + g y)%term + | (x * y)%term => (f x * g y)%term | x => x end. @@ -849,31 +846,25 @@ Qed. (* \subsubsection{La tactique pour prouver la stabilité} *) Ltac loop t := - match constr:t with - | (?X1 = ?X2) => - (* Global *) - loop X1 || loop X2 + match t with + (* Global *) + | (?X1 = ?X2) => loop X1 || loop X2 | (_ -> ?X1) => loop X1 - | (interp_hyps _ _ ?X1) => - (* Interpretations *) - loop X1 + | (interp_hyps _ _ ?X1) => loop X1 | (interp_list_hyps _ _ ?X1) => loop X1 | (interp_proposition _ _ ?X1) => loop X1 | (interp_term _ ?X1) => loop X1 - | (EqTerm ?X1 ?X2) => - - (* Propositions *) - loop X1 || loop X2 + (* Propositions *) + | (EqTerm ?X1 ?X2) => loop X1 || loop X2 | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - | (Tplus ?X1 ?X2) => - (* Termes *) - loop X1 || loop X2 - | (Tminus ?X1 ?X2) => loop X1 || loop X2 - | (Tmult ?X1 ?X2) => loop X1 || loop X2 - | (Topp ?X1) => loop X1 - | (Tint ?X1) => - loop X1 + (* 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 => _ @@ -889,8 +880,6 @@ Ltac loop t := | Timp x x0 => _ | Tprop x => _ end => - - (* Eliminations *) case X1; [ intro; intro | intro; intro @@ -907,19 +896,19 @@ Ltac loop t := | intro ]; auto; Simplify | match ?X1 with | Tint x => _ - | Tplus x x0 => _ - | Tmult x x0 => _ - | Tminus x x0 => _ - | Topp x => _ - | Tvar x => _ + | (x + x0)%term => _ + | (x * x0)%term => _ + | (x - x0)%term => _ + | (- x)%term => _ + | [x]%term => _ end => case X1; [ intro | intro; intro | intro; intro | intro; intro | intro | intro ]; auto; Simplify - | match (?X1 ?= ?X2)%Z with - | Datatypes.Eq => _ - | Datatypes.Lt => _ - | Datatypes.Gt => _ + | match ?X1 ?= ?X2 with + | Eq => _ + | Lt => _ + | Gt => _ end => elim_Zcompare X1 X2; intro; auto; Simplify | match ?X1 with @@ -955,7 +944,7 @@ Ltac prove_stable x th := (* \subsubsection{Les règles elle mêmes} *) Definition Tplus_assoc_l (t : term) := match t with - | Tplus n (Tplus m p) => Tplus (Tplus n m) p + | (n + (m + p))%term => (n + m + p)%term | _ => t end. @@ -966,7 +955,7 @@ Qed. Definition Tplus_assoc_r (t : term) := match t with - | Tplus (Tplus n m) p => Tplus n (Tplus m p) + | (n + m + p)%term => (n + (m + p))%term | _ => t end. @@ -977,7 +966,7 @@ Qed. Definition Tmult_assoc_r (t : term) := match t with - | Tmult (Tmult n m) p => Tmult n (Tmult m p) + | (n * m * p)%term => (n * (m * p))%term | _ => t end. @@ -988,7 +977,7 @@ Qed. Definition Tplus_permute (t : term) := match t with - | Tplus n (Tplus m p) => Tplus m (Tplus n p) + | (n + (m + p))%term => (m + (n + p))%term | _ => t end. @@ -999,7 +988,7 @@ Qed. Definition Tplus_sym (t : term) := match t with - | Tplus x y => Tplus y x + | (x + y)%term => (y + x)%term | _ => t end. @@ -1010,7 +999,7 @@ Qed. Definition Tmult_sym (t : term) := match t with - | Tmult x y => Tmult y x + | (x * y)%term => (y * x)%term | _ => t end. @@ -1021,12 +1010,10 @@ Qed. Definition T_OMEGA10 (t : term) := match t with - | Tplus (Tmult (Tplus (Tmult v (Tint c1)) l1) (Tint k1)) (Tmult (Tplus - (Tmult v' (Tint c2)) l2) (Tint k2)) => + | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => match eq_term v v' with | true => - Tplus (Tmult v (Tint (c1 * k1 + c2 * k2))) - (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2))) + (v * Tint (c1 * k1 + c2 * k2) + (l1 * Tint k1 + l2 * Tint k2))%term | false => t end | _ => t @@ -1039,8 +1026,8 @@ Qed. Definition T_OMEGA11 (t : term) := match t with - | Tplus (Tmult (Tplus (Tmult v1 (Tint c1)) l1) (Tint k1)) l2 => - Tplus (Tmult v1 (Tint (c1 * k1))) (Tplus (Tmult l1 (Tint k1)) l2) + | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => + (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term | _ => t end. @@ -1051,8 +1038,8 @@ Qed. Definition T_OMEGA12 (t : term) := match t with - | Tplus l1 (Tmult (Tplus (Tmult v2 (Tint c2)) l2) (Tint k2)) => - Tplus (Tmult v2 (Tint (c2 * k2))) (Tplus l1 (Tmult l2 (Tint k2))) + | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => + (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term | _ => t end. @@ -1063,22 +1050,22 @@ Qed. Definition T_OMEGA13 (t : term) := match t with - | Tplus (Tplus (Tmult v (Tint (Zpos x))) l1) (Tplus (Tmult v' (Tint (Zneg - x'))) l2) => + | (v * Tint (Zpos x) + l1 + (v' * Tint (Zneg x') + l2))%term => match eq_term v v' with - | true => match eq_pos x x' with - | true => Tplus l1 l2 - | false => t - end + | true => + match eq_pos x x' with + | true => (l1 + l2)%term + | false => t + end | false => t end - | Tplus (Tplus (Tmult v (Tint (Zneg x))) l1) (Tplus (Tmult v' (Tint (Zpos - x'))) l2) => + | (v * Tint (Zneg x) + l1 + (v' * Tint (Zpos x') + l2))%term => match eq_term v v' with - | true => match eq_pos x x' with - | true => Tplus l1 l2 - | false => t - end + | true => + match eq_pos x x' with + | true => (l1 + l2)%term + | false => t + end | false => t end | _ => t @@ -1092,12 +1079,9 @@ Qed. Definition T_OMEGA15 (t : term) := match t with - | Tplus (Tplus (Tmult v (Tint c1)) l1) (Tmult (Tplus (Tmult v' (Tint c2)) - l2) (Tint k2)) => + | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => match eq_term v v' with - | true => - Tplus (Tmult v (Tint (c1 + c2 * k2))) - (Tplus l1 (Tmult l2 (Tint k2))) + | true => (v * Tint (c1 + c2 * k2) + (l1 + l2 * Tint k2))%term | false => t end | _ => t @@ -1110,8 +1094,7 @@ Qed. Definition T_OMEGA16 (t : term) := match t with - | Tmult (Tplus (Tmult v (Tint c)) l) (Tint k) => - Tplus (Tmult v (Tint (c * k))) (Tmult l (Tint k)) + | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term | _ => t end. @@ -1123,7 +1106,7 @@ Qed. Definition Tred_factor5 (t : term) := match t with - | Tplus (Tmult x (Tint Z0)) y => y + | (x * Tint Z0 + y)%term => y | _ => t end. @@ -1135,7 +1118,7 @@ Qed. Definition Topp_plus (t : term) := match t with - | Topp (Tplus x y) => Tplus (Topp x) (Topp y) + | (- (x + y))%term => (- x + - y)%term | _ => t end. @@ -1147,7 +1130,7 @@ Qed. Definition Topp_opp (t : term) := match t with - | Topp (Topp x) => x + | (- - x)%term => x | _ => t end. @@ -1158,7 +1141,7 @@ Qed. Definition Topp_mult_r (t : term) := match t with - | Topp (Tmult x (Tint k)) => Tmult x (Tint (- k)) + | (- (x * Tint k))%term => (x * Tint (- k))%term | _ => t end. @@ -1169,7 +1152,7 @@ Qed. Definition Topp_one (t : term) := match t with - | Topp x => Tmult x (Tint (-1)) + | (- x)%term => (x * Tint (-1))%term | _ => t end. @@ -1180,7 +1163,7 @@ Qed. Definition Tmult_plus_distr (t : term) := match t with - | Tmult (Tplus n m) p => Tplus (Tmult n p) (Tmult m p) + | ((n + m) * p)%term => (n * p + m * p)%term | _ => t end. @@ -1191,7 +1174,7 @@ Qed. Definition Tmult_opp_left (t : term) := match t with - | Tmult (Topp x) (Tint y) => Tmult x (Tint (- y)) + | (- x * Tint y)%term => (x * Tint (- y))%term | _ => t end. @@ -1202,7 +1185,7 @@ Qed. Definition Tmult_assoc_reduced (t : term) := match t with - | Tmult (Tmult n (Tint m)) (Tint p) => Tmult n (Tint (m * p)) + | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term | _ => t end. @@ -1211,7 +1194,7 @@ Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. prove_stable Tmult_assoc_reduced Zmult_assoc_reverse. Qed. -Definition Tred_factor0 (t : term) := Tmult t (Tint 1). +Definition Tred_factor0 (t : term) := (t * Tint 1)%term. Theorem Tred_factor0_stable : term_stable Tred_factor0. @@ -1220,9 +1203,9 @@ Qed. Definition Tred_factor1 (t : term) := match t with - | Tplus x y => + | (x + y)%term => match eq_term x y with - | true => Tmult x (Tint 2) + | true => (x * Tint 2)%term | false => t end | _ => t @@ -1235,9 +1218,9 @@ Qed. Definition Tred_factor2 (t : term) := match t with - | Tplus x (Tmult y (Tint k)) => + | (x + y * Tint k)%term => match eq_term x y with - | true => Tmult x (Tint (1 + k)) + | true => (x * Tint (1 + k))%term | false => t end | _ => t @@ -1254,9 +1237,9 @@ Qed. Definition Tred_factor3 (t : term) := match t with - | Tplus (Tmult x (Tint k)) y => + | (x * Tint k + y)%term => match eq_term x y with - | true => Tmult x (Tint (1 + k)) + | true => (x * Tint (1 + k))%term | false => t end | _ => t @@ -1270,9 +1253,9 @@ Qed. Definition Tred_factor4 (t : term) := match t with - | Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2)) => + | (x * Tint k1 + y * Tint k2)%term => match eq_term x y with - | true => Tmult x (Tint (k1 + k2)) + | true => (x * Tint (k1 + k2))%term | false => t end | _ => t @@ -1283,7 +1266,7 @@ Theorem Tred_factor4_stable : term_stable Tred_factor4. prove_stable Tred_factor4 Zred_factor4. Qed. -Definition Tred_factor6 (t : term) := Tplus t (Tint 0). +Definition Tred_factor6 (t : term) := (t + Tint 0)%term. Theorem Tred_factor6_stable : term_stable Tred_factor6. @@ -1294,7 +1277,7 @@ Transparent Zplus. Definition Tminus_def (t : term) := match t with - | Tminus x y => Tplus x (Topp y) + | (x - y)%term => (x + - y)%term | _ => t end. @@ -1313,37 +1296,37 @@ Qed. Fixpoint reduce (t : term) : term := match t with - | Tplus x y => + | (x + y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' + y') - | y' => Tplus (Tint x') y' + | y' => (Tint x' + y')%term end - | x' => Tplus x' (reduce y) + | x' => (x' + reduce y)%term end - | Tmult x y => + | (x * y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' * y') - | y' => Tmult (Tint x') y' + | y' => (Tint x' * y')%term end - | x' => Tmult x' (reduce y) + | x' => (x' * reduce y)%term end - | Tminus x y => + | (x - y)%term => match reduce x with | Tint x' => match reduce y with | Tint y' => Tint (x' - y') - | y' => Tminus (Tint x') y' + | y' => (Tint x' - y')%term end - | x' => Tminus x' (reduce y) + | x' => (x' - reduce y)%term end - | Topp x => + | (- x)%term => match reduce x with | Tint x' => Tint (- x') - | x' => Topp x' + | x' => (- x')%term end | _ => t end. @@ -1412,7 +1395,7 @@ Definition fusion_right (trace : list t_fusion) (t : term) : term := end end. -(* \paragraph{Fusion avec anihilation} *) +(* \paragraph{Fusion avec annihilation} *) (* Normalement le résultat est une constante *) Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := @@ -1428,7 +1411,7 @@ unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. Qed. -(* \subsubsection{Opérations afines sur une équation} *) +(* \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 := @@ -1497,7 +1480,7 @@ Fixpoint rewrite (s : step) : term -> term := | C_PLUS_ASSOC_R => Tplus_assoc_r | C_PLUS_ASSOC_L => Tplus_assoc_l | C_PLUS_PERMUTE => Tplus_permute - | C_PLUS_SYM => Tplus_sym + | C_PLUS_COMM => Tplus_sym | C_RED0 => Tred_factor0 | C_RED1 => Tred_factor1 | C_RED2 => Tred_factor2 @@ -1507,7 +1490,7 @@ Fixpoint rewrite (s : step) : term -> term := | C_RED6 => Tred_factor6 | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced | C_MINUS => Tminus_def - | C_MULT_SYM => Tmult_sym + | C_MULT_COMM => Tmult_sym end. Theorem rewrite_stable : forall s : step, term_stable (rewrite s). @@ -1547,7 +1530,7 @@ Qed. \subsubsection{Tactiques générant une contradiction} \paragraph{[O_CONSTANT_NOT_NUL]} *) -Definition constant_not_nul (i : nat) (h : list proposition) := +Definition constant_not_nul (i : nat) (h : hyps) := match nth_hyps i h with | EqTerm (Tint Z0) (Tint n) => match eq_Z n 0 with @@ -1562,13 +1545,13 @@ Theorem constant_not_nul_valid : unfold valid_hyps, constant_not_nul in |- *; intros; generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - elim_eq_Z ipattern:z0 0%Z; auto; simpl in |- *; intros H1 H2; + elim_eq_Z ipattern:z0 0; auto; simpl in |- *; intros H1 H2; elim H1; symmetry in |- *; auto. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) -Definition constant_neg (i : nat) (h : list proposition) := +Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd | _ => h @@ -1584,18 +1567,17 @@ Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) Definition not_exact_divide (k1 k2 : Z) (body : term) - (t i : nat) (l : list proposition) := + (t i : nat) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Z0) b => match - eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) - b + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b with | true => - match (k2 ?= 0)%Z with - | Datatypes.Gt => - match (k1 ?= k2)%Z with - | Datatypes.Gt => absurd + match k2 ?= 0 with + | Gt => + match k1 ?= k2 with + | Gt => absurd | _ => l end | _ => l @@ -1611,27 +1593,26 @@ Theorem not_exact_divide_valid : unfold valid_hyps, not_exact_divide in |- *; intros; generalize (nth_valid ep e i lp); Simplify; - elim_eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) t1; + elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; auto; Simplify; intro H2; elim H2; simpl in |- *; elim (scalar_norm_add_stable t e); simpl in |- *; - intro H4; absurd ((interp_term e body * k1 + k2)%Z = 0%Z); + intro H4; absurd (interp_term e body * k1 + k2 = 0); [ apply OMEGA4; assumption | symmetry in |- *; auto ]. Qed. (* \paragraph{[O_CONTRADICTION]} *) -Definition contradiction (t i j : nat) (l : list proposition) := +Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps i l with | LeqTerm (Tint Z0) b1 => match nth_hyps j l with | LeqTerm (Tint Z0) b2 => - match fusion_cancel t (Tplus b1 b2) with - | Tint k => - match (0 ?= k)%Z with - | Datatypes.Gt => absurd - | _ => l - end + match fusion_cancel t (b1 + b2)%term with + | Tint k => match 0 ?= k with + | Gt => absurd + | _ => l + end | _ => l end | _ => l @@ -1648,9 +1629,9 @@ unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; auto; intros z; case z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; case z'; auto; simpl in |- *; intros H1 H2; - generalize (refl_equal (interp_term e (fusion_cancel t (Tplus t2 t4)))); - pattern (fusion_cancel t (Tplus t2 t4)) at 2 3 in |- *; - case (fusion_cancel t (Tplus t2 t4)); simpl in |- *; + 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 |- *; intro E; generalize (OMEGA2 _ _ H2 H1); rewrite E; case k; auto; unfold Zle in |- *; simpl in |- *; intros p H3; @@ -1660,7 +1641,7 @@ Qed. (* \paragraph{[O_NEGATE_CONTRADICT]} *) -Definition negate_contradict (i1 i2 : nat) (h : list proposition) := +Definition negate_contradict (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Z0) b1 => match nth_hyps i2 h with @@ -1683,12 +1664,12 @@ Definition negate_contradict (i1 i2 : nat) (h : list proposition) := | _ => h end. -Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) := +Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Z0) b1 => match nth_hyps i2 h with | NeqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with + match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with | true => absurd | false => h end @@ -1697,7 +1678,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) := | NeqTerm (Tint Z0) b1 => match nth_hyps i2 h with | EqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with + match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with | true => absurd | false => h end @@ -1732,11 +1713,11 @@ unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; auto; intros z; case z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; case z'; auto; simpl in |- *; intros H1 H2; - (pattern (eq_term t2 (scalar_norm t (Tmult t4 (Tint (-1))))) in |- *; + (pattern (eq_term t2 (scalar_norm t (t4 * Tint (-1))%term)) in |- *; apply bool_ind2; intro Aux; - [ generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux); + [ generalize (eq_term_true t2 (scalar_norm t (t4 * Tint (-1))%term) Aux); clear Aux - | generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux); + | generalize (eq_term_false t2 (scalar_norm t (t4 * Tint (-1))%term) Aux); clear Aux ]); [ intro H3; elim H1; generalize H2; rewrite H3; rewrite <- (scalar_norm_stable t e); simpl in |- *; @@ -1762,32 +1743,28 @@ Definition sum (k1 k2 : Z) (trace : list t_fusion) | EqTerm (Tint Z0) b1 => match prop2 with | EqTerm (Tint Z0) b2 => - EqTerm (Tint 0) - (fusion trace (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) | LeqTerm (Tint Z0) b2 => - match (k2 ?= 0)%Z with - | Datatypes.Gt => + match k2 ?= 0 with + | Gt => LeqTerm (Tint 0) - (fusion trace - (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) | _ => TrueTerm end | _ => TrueTerm end | LeqTerm (Tint Z0) b1 => - match (k1 ?= 0)%Z with - | Datatypes.Gt => + match k1 ?= 0 with + | Gt => match prop2 with | EqTerm (Tint Z0) b2 => LeqTerm (Tint 0) - (fusion trace - (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) | LeqTerm (Tint Z0) b2 => - match (k2 ?= 0)%Z with - | Datatypes.Gt => + match k2 ?= 0 with + | Gt => LeqTerm (Tint 0) - (fusion trace - (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) | _ => TrueTerm end | _ => TrueTerm @@ -1801,23 +1778,20 @@ Definition sum (k1 k2 : Z) (trace : list t_fusion) | true => TrueTerm | false => NeqTerm (Tint 0) - (fusion trace - (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) end | _ => TrueTerm end | _ => TrueTerm end. -Theorem sum1 : - forall a b c d : Z, 0%Z = a -> 0%Z = b -> 0%Z = (a * c + b * d)%Z. +Theorem sum1 : forall a b c d : Z, 0 = a -> 0 = b -> 0 = a * c + b * d. intros; elim H; elim H0; simpl in |- *; auto. Qed. Theorem sum2 : - forall a b c d : Z, - (0 <= d)%Z -> 0%Z = a -> (0 <= b)%Z -> (0 <= a * c + b * d)%Z. + forall a b c d : Z, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. intros; elim H0; simpl in |- *; generalize H H1; case b; case d; unfold Zle in |- *; simpl in |- *; auto. @@ -1825,21 +1799,19 @@ Qed. Theorem sum3 : forall a b c d : Z, - (0 <= c)%Z -> - (0 <= d)%Z -> (0 <= a)%Z -> (0 <= b)%Z -> (0 <= a * c + b * d)%Z. + 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. intros a b c d; case a; case b; case c; case d; unfold Zle in |- *; simpl in |- *; auto. Qed. -Theorem sum4 : forall k : Z, (k ?= 0)%Z = Datatypes.Gt -> (0 <= k)%Z. +Theorem sum4 : forall k : Z, (k ?= 0) = Gt -> 0 <= k. intro; case k; unfold Zle in |- *; simpl in |- *; auto; intros; discriminate. Qed. Theorem sum5 : - forall a b c d : Z, - c <> 0%Z -> 0%Z <> a -> 0%Z = b -> 0%Z <> (a * c + b * d)%Z. + forall a b c d : Z, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. intros a b c d H1 H2 H3; elim H3; simpl in |- *; rewrite Zplus_comm; simpl in |- *; generalize H1 H2; case a; case c; simpl in |- *; @@ -1857,9 +1829,8 @@ unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; | apply sum2; try assumption; apply sum4; assumption | rewrite Zplus_comm; apply sum2; try assumption; apply sum4; assumption | apply sum3; try assumption; apply sum4; assumption - | elim_eq_Z k1 0%Z; simpl in |- *; auto; elim (fusion_stable t); - simpl in |- *; intros; unfold Zne in |- *; apply sum5; - assumption ]. + | elim_eq_Z k1 0; simpl in |- *; auto; elim (fusion_stable t); simpl in |- *; + intros; unfold Zne in |- *; apply sum5; assumption ]. Qed. (* \paragraph{[O_EXACT_DIVIDE]} @@ -1869,7 +1840,7 @@ Definition exact_divide (k : Z) (body : term) (t : nat) (prop : proposition) := match prop with | EqTerm (Tint Z0) b => - match eq_term (scalar_norm t (Tmult body (Tint k))) b with + match eq_term (scalar_norm t (body * Tint k)%term) b with | true => match eq_Z k 0 with | true => TrueTerm @@ -1885,13 +1856,13 @@ Theorem exact_divide_valid : unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify; - simpl in |- *; auto; elim_eq_term (scalar_norm t (Tmult k2 (Tint k1))) t1; - simpl in |- *; auto; elim_eq_Z k1 0%Z; simpl in |- *; + simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1; + simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *; auto; intros H1 H2; elim H2; elim scalar_norm_stable; simpl in |- *; generalize H1; case (interp_term e k2); try trivial; (case k1; simpl in |- *; - [ intros; absurd (0%Z = 0%Z); assumption + [ intros; absurd (0 = 0); assumption | intros p2 p3 H3 H4; discriminate H4 | intros p2 p3 H3 H4; discriminate H4 ]). @@ -1908,14 +1879,13 @@ Definition divide_and_approx (k1 k2 : Z) (body : term) match prop with | LeqTerm (Tint Z0) b => match - eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) - b + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b with | true => - match (k1 ?= 0)%Z with - | Datatypes.Gt => - match (k1 ?= k2)%Z with - | Datatypes.Gt => LeqTerm (Tint 0) body + match k1 ?= 0 with + | Gt => + match k1 ?= k2 with + | Gt => LeqTerm (Tint 0) body | _ => prop end | _ => prop @@ -1931,7 +1901,7 @@ Theorem divide_and_approx_valid : unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; Simplify; - elim_eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) t1; + elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1; Simplify; auto; intro E; elim E; simpl in |- *; elim (scalar_norm_add_stable t e); simpl in |- *; intro H1; apply Zmult_le_approx with (3 := H1); assumption. @@ -1944,7 +1914,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := | LeqTerm (Tint Z0) b1 => match prop2 with | LeqTerm (Tint Z0) b2 => - match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with + match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with | true => EqTerm (Tint 0) b1 | false => TrueTerm end @@ -1965,7 +1935,7 @@ Qed. (* \paragraph{[O_CONSTANT_NUL]} *) -Definition constant_nul (i : nat) (h : list proposition) := +Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with | NeqTerm (Tint Z0) (Tint Z0) => absurd | _ => h @@ -1975,8 +1945,7 @@ Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). unfold valid_hyps, constant_nul in |- *; intros; generalize (nth_valid ep e i lp); Simplify; simpl in |- *; - unfold Zne in |- *; intro H1; absurd (0%Z = 0%Z); - auto. + unfold Zne in |- *; intro H1; absurd (0 = 0); auto. Qed. (* \paragraph{[O_STATE]} *) @@ -1985,9 +1954,8 @@ Definition state (m : Z) (s : step) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Z0) b1 => match prop2 with - | EqTerm (Tint Z0) (Tplus b2 (Topp b3)) => - EqTerm (Tint 0) - (rewrite s (Tplus b1 (Tmult (Tplus (Topp b3) b2) (Tint m)))) + | EqTerm (Tint Z0) (b2 + - b3)%term => + EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) | _ => TrueTerm end | _ => TrueTerm @@ -2007,21 +1975,19 @@ Qed. \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 : list proposition -> list (list proposition)) - (l : list proposition) := +Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) + (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Z0) b1 => - f1 (LeqTerm (Tint 0) (add_norm t (Tplus b1 (Tint (-1)))) :: l) ++ + f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-1))%term) :: l) ++ f2 (LeqTerm (Tint 0) - (scalar_norm_add t (Tplus (Tmult b1 (Tint (-1))) (Tint (-1)))) - :: l) + (scalar_norm_add t (b1 * Tint (-1) + Tint (-1))%term) :: l) | _ => l :: nil end. Theorem split_ineq_valid : - forall (i t : nat) (f1 f2 : list proposition -> list (list proposition)), + 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). @@ -2041,34 +2007,27 @@ Qed. (* \subsection{La fonction de rejeu de la trace} *) -Fixpoint execute_omega (t : t_omega) (l : list proposition) {struct t} : - list (list proposition) := +Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with - | O_CONSTANT_NOT_NUL n => - (fun a : list proposition => a :: nil) (constant_not_nul n l) - | O_CONSTANT_NEG n => - (fun a : list proposition => a :: nil) (constant_neg n l) + | 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 => - (fun a : list proposition => a :: nil) - (not_exact_divide k1 k2 body t i l) + 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 => - (fun a : list proposition => a :: nil) (contradiction t i j 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 => - (fun a : list proposition => a :: nil) (constant_nul i l) - | O_NEGATE_CONTRADICT i j => - (fun a : list proposition => a :: nil) (negate_contradict i j 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 => - (fun a : list proposition => a :: nil) (negate_contradict_inv t i j l) + 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. @@ -2126,14 +2085,12 @@ Qed. Definition move_right (s : step) (p : proposition) := match p with - | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2))) - | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (Tplus t2 (Topp t1))) - | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2))) - | LtTerm t1 t2 => - LeqTerm (Tint 0) (rewrite s (Tplus (Tplus t2 (Tint (-1))) (Topp t1))) - | GtTerm t1 t2 => - LeqTerm (Tint 0) (rewrite s (Tplus (Tplus t1 (Tint (-1))) (Topp t2))) - | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (Tplus t1 (Topp t2))) + | 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. @@ -2165,7 +2122,7 @@ intros; unfold do_normalize in |- *; apply apply_oper_1_valid; Qed. Fixpoint do_normalize_list (l : list step) (i : nat) - (h : list proposition) {struct l} : list proposition := + (h : hyps) {struct l} : hyps := match l with | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) | nil => h @@ -2181,11 +2138,8 @@ simple induction l; simpl in |- *; unfold valid_hyps in |- *; Qed. Theorem normalize_goal : - forall (s : list step) (ep : PropList) (env : list Z) (l : list proposition), - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env (do_normalize_list s 0 l) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env l. + forall (s : list step) (ep : PropList) (env : list Z) (l : hyps), + interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. Qed. @@ -2193,17 +2147,15 @@ Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : - forall (t : t_omega) (ep : PropList) (env : list Z) (l : list proposition), - interp_list_goal ep env (execute_omega t l) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env l. + forall (t : t_omega) (ep : PropList) (env : list Z) (l : hyps), + interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). Qed. Theorem append_goal : - forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)), + forall (ep : PropList) (e : list Z) (l1 l2 : lhyps), interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> interp_list_goal ep e (l1 ++ l2). @@ -2262,15 +2214,15 @@ Qed. conclusion. We use an intermediate fixpoint. *) Fixpoint interp_full_goal (envp : PropList) (env : list Z) - (c : proposition) (l : list proposition) {struct l} : Prop := + (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 : PropList) (e : list Z) - (lc : list proposition * proposition) : Prop := +Definition interp_full (ep : PropList) (e : list Z) + (lc : hyps * proposition) : Prop := match lc with | (l, c) => interp_full_goal ep e c l end. @@ -2279,7 +2231,7 @@ Definition interp_full (ep : PropList) (e : list Z) of its hypothesis and conclusion *) Theorem interp_full_false : - forall (ep : PropList) (e : list Z) (l : list proposition) (c : proposition), + forall (ep : PropList) (e : list Z) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). simple induction l; unfold interp_full in |- *; simpl in |- *; @@ -2291,7 +2243,7 @@ Qed. If the decidability cannot be "proven", then just forget about the conclusion (equivalent of replacing it with false) *) -Definition to_contradict (lc : list proposition * proposition) := +Definition to_contradict (lc : hyps * proposition) := match lc with | (l, c) => if decidability c then Tnot c :: l else l end. @@ -2300,10 +2252,8 @@ Definition to_contradict (lc : list proposition * proposition) := hypothesis implies the original goal *) Theorem to_contradict_valid : - forall (ep : PropList) (e : list Z) (lc : list proposition * proposition), - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep e (to_contradict lc) -> - interp_full ep e lc. + forall (ep : PropList) (e : list Z) (lc : hyps * proposition), + interp_goal ep e (to_contradict lc) -> interp_full ep e lc. intros ep e lc; case lc; intros l c; simpl in |- *; pattern (decidability c) in |- *; apply bool_ind2; @@ -2336,8 +2286,7 @@ Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : hypothesis will get desynchronised and this will be a mess. *) -Fixpoint destructure_hyps (nn : nat) (ll : list proposition) {struct nn} : - list (list proposition) := +Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := match nn with | O => ll :: nil | S n => @@ -2371,8 +2320,7 @@ Fixpoint destructure_hyps (nn : nat) (ll : list proposition) {struct nn} : end. Theorem map_cons_val : - forall (ep : PropList) (e : list Z) (p : proposition) - (l : list (list proposition)), + forall (ep : PropList) (e : list Z) (p : proposition) (l : lhyps), interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). @@ -2514,7 +2462,7 @@ unfold prop_stable in |- *; intros f H ep e p; split; unfold decidable, Zne in |- *; tauto ]). Qed. -Theorem Zlt_left_inv : forall x y : Z, (0 <= y + -1 + - x)%Z -> (x < y)%Z. +Theorem Zlt_left_inv : forall x y : Z, 0 <= y + -1 + - x -> x < y. intros; apply Zsucc_lt_reg; apply Zle_lt_succ; apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); @@ -2570,8 +2518,7 @@ simple induction s; simpl in |- *; | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ]. Qed. -Fixpoint normalize_hyps (l : list h_step) (lh : list proposition) {struct l} - : list proposition := +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) @@ -2590,12 +2537,8 @@ simple induction l; unfold valid_hyps in |- *; simpl in |- *; Qed. Theorem normalize_hyps_goal : - forall (s : list h_step) (ep : PropList) (env : list Z) - (l : list proposition), - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env (normalize_hyps s l) -> - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) ep env l. + forall (s : list h_step) (ep : PropList) (env : list Z) (l : hyps), + interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. @@ -2675,8 +2618,7 @@ unfold valid1, co_valid1 in |- *; simple induction s; Qed. -Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} : - list (list proposition) := +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 @@ -2687,6 +2629,10 @@ Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} : 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 => @@ -2710,28 +2656,32 @@ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; | 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 H3; right; apply H0; simpl in |- *; auto ] + | intros p1 p2 H2; + pattern (decidability p1) in |- *; apply bool_ind2; + [ 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 : list (list proposition) -> list (list proposition)) := - forall (ep : PropList) (e : list Z) (lp : list (list proposition)), +Definition valid_lhyps (f : lhyps -> lhyps) := + forall (ep : PropList) (e : list Z) (lp : lhyps), interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). -Fixpoint reduce_lhyps (lp : list (list proposition)) : - list (list proposition) := +Fixpoint reduce_lhyps (lp : lhyps) : lhyps := match lp with | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' | x :: lp' => x :: reduce_lhyps lp' - | nil => nil (A:=list proposition) + | nil => nil (A:=hyps) end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. @@ -2744,7 +2694,7 @@ unfold valid_lhyps in |- *; intros ep e lp; elim lp; Qed. Theorem do_reduce_lhyps : - forall (envp : PropList) (env : list Z) (l : list (list proposition)), + forall (envp : PropList) (env : list Z) (l : lhyps), interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. intros envp env l H; apply list_goal_to_hyps; intro H1; @@ -2756,13 +2706,11 @@ Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. Definition do_concl_to_hyp : - forall (envp : PropList) (env : list Z) (c : proposition) - (l : list proposition), - (fun (envp : PropList) (env : list Z) (l : list proposition) => - interp_goal_concl envp env FalseTerm l) envp env ( - concl_to_hyp c :: l) -> interp_goal_concl envp env c l. + forall (envp : PropList) (env : list Z) (c : proposition) (l : hyps), + interp_goal envp env (concl_to_hyp c :: l) -> + interp_goal_concl c envp env l. -simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; +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_ind2; [ intro H; generalize (decidable_correct envp env c H); @@ -2772,16 +2720,16 @@ simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) - (c : proposition) (l : list proposition) := + (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 : PropList) - (env : list Z) (c : proposition) (l : list proposition), + (env : list Z) (c : proposition) (l : hyps), interp_list_goal envp env (omega_tactic t1 t2 c l) -> - interp_goal_concl envp env c l. + interp_goal_concl c envp env l. 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.
\ No newline at end of file +Qed. diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml index 3b2a7d31..69b4b2de 100644 --- a/contrib/romega/const_omega.ml +++ b/contrib/romega/const_omega.ml @@ -17,7 +17,6 @@ type result = let destructurate t = let c, args = Term.decompose_app t in - let env = Global.env() in match Term.kind_of_term c, args with | Term.Const sp, args -> Kapp (Names.string_of_id @@ -43,7 +42,7 @@ 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.Const sp -> Libnames.ConstRef sp | Term.Construct csp -> Libnames.ConstructRef csp | Term.Ind isp -> Libnames.IndRef isp | _ -> raise Destruct @@ -53,14 +52,16 @@ let recognize_number t = let rec loop t = let f,l = dest_const_apply t in match Names.string_of_id f,l with - "xI",[t] -> 1 + 2 * loop t - | "xO",[t] -> 2 * loop t - | "xH",[] -> 1 + "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] -> - (loop t) | "Z0",[] -> 0 - | _ -> failwith "not a number";; + "Zpos",[t] -> loop t + | "Zneg",[t] -> Bigint.neg (loop t) + | "Z0",[] -> Bigint.zero + | _ -> failwith "not a number";; let logic_dir = ["Coq";"Logic";"Decidable"] @@ -68,7 +69,7 @@ let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] - @ [["Coq"; "Lists"; (if !Options.v7 then "PolyList" else "List")]] + @ [["Coq"; "Lists"; "List"]] @ [module_refl_path] @@ -77,23 +78,23 @@ let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") let coq_xI = lazy (constant "xI") -let coq_ZERO = lazy (constant "Z0") -let coq_POS = lazy (constant "Zpos") -let coq_NEG = lazy (constant "Zneg") +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_relation = lazy (constant "comparison") -let coq_SUPERIEUR = lazy (constant "SUPERIEUR") -let coq_INFEEIEUR = lazy (constant "INFERIEUR") -let coq_EGAL = lazy (constant "EGAL") +let coq_comparison = lazy (constant "comparison") +let coq_Gt = lazy (constant "Gt") +let coq_Lt = lazy (constant "Lt") +let coq_Eq = lazy (constant "Eq") 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_Zs = lazy (constant "Zs") +let coq_Zsucc = lazy (constant "Zsucc") let coq_Zgt = lazy (constant "Zgt") let coq_Zle = lazy (constant "Zle") -let coq_inject_nat = lazy (constant "inject_nat") +let coq_Z_of_nat = lazy (constant "Z_of_nat") (* Peano *) let coq_le = lazy(constant "le") @@ -111,8 +112,8 @@ 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_True = lazy(constant "True") +let coq_False = lazy(constant "False") let coq_ex = lazy(constant "ex") let coq_I = lazy(constant "I") @@ -159,8 +160,7 @@ let coq_normalize_sequent = lazy (constant "normalize_goal") let coq_execute_sequent = lazy (constant "execute_goal") let coq_do_concl_to_hyp = lazy (constant "do_concl_to_hyp") let coq_sequent_to_hyps = lazy (constant "goal_to_hyps") -let coq_normalize_hyps_goal = - lazy (constant "normalize_hyps_goal") +let coq_normalize_hyps_goal = lazy (constant "normalize_hyps_goal") (* Constructors for shuffle tactic *) let coq_t_fusion = lazy (constant "t_fusion") @@ -187,7 +187,7 @@ 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_sym = lazy (constant "C_PLUS_SYM") +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") @@ -199,7 +199,7 @@ 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_sym = lazy (constant "C_MULT_SYM") +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") @@ -230,184 +230,6 @@ let coq_decompose_solve_valid = let coq_do_reduce_lhyps = lazy (constant "do_reduce_lhyps") let coq_do_omega = lazy (constant "do_omega") -(** -let constant dir s = - try - Libnames.constr_of_reference - (Nametab.absolute_reference - (Libnames.make_path - (Names.make_dirpath (List.map Names.id_of_string (List.rev dir))) - (Names.id_of_string s))) - with e -> print_endline (String.concat "." dir); print_endline s; - raise e - -let path_fast_integer = ["Coq"; "ZArith"; "fast_integer"] -let path_zarith_aux = ["Coq"; "ZArith"; "zarith_aux"] -let path_logic = ["Coq"; "Init";"Logic"] -let path_datatypes = ["Coq"; "Init";"Datatypes"] -let path_peano = ["Coq"; "Init"; "Peano"] -let path_list = ["Coq"; "Lists"; "PolyList"] - -let coq_xH = lazy (constant path_fast_integer "xH") -let coq_xO = lazy (constant path_fast_integer "xO") -let coq_xI = lazy (constant path_fast_integer "xI") -let coq_ZERO = lazy (constant path_fast_integer "ZERO") -let coq_POS = lazy (constant path_fast_integer "POS") -let coq_NEG = lazy (constant path_fast_integer "NEG") -let coq_Z = lazy (constant path_fast_integer "Z") -let coq_relation = lazy (constant path_fast_integer "relation") -let coq_SUPERIEUR = lazy (constant path_fast_integer "SUPERIEUR") -let coq_INFEEIEUR = lazy (constant path_fast_integer "INFERIEUR") -let coq_EGAL = lazy (constant path_fast_integer "EGAL") -let coq_Zplus = lazy (constant path_fast_integer "Zplus") -let coq_Zmult = lazy (constant path_fast_integer "Zmult") -let coq_Zopp = lazy (constant path_fast_integer "Zopp") - -(* auxiliaires zarith *) -let coq_Zminus = lazy (constant path_zarith_aux "Zminus") -let coq_Zs = lazy (constant path_zarith_aux "Zs") -let coq_Zgt = lazy (constant path_zarith_aux "Zgt") -let coq_Zle = lazy (constant path_zarith_aux "Zle") -let coq_inject_nat = lazy (constant path_zarith_aux "inject_nat") - -(* Peano *) -let coq_le = lazy(constant path_peano "le") -let coq_gt = lazy(constant path_peano "gt") - -(* Integers *) -let coq_nat = lazy(constant path_datatypes "nat") -let coq_S = lazy(constant path_datatypes "S") -let coq_O = lazy(constant path_datatypes "O") - -(* Minus *) -let coq_minus = lazy(constant ["Arith"; "Minus"] "minus") - -(* Logic *) -let coq_eq = lazy(constant path_logic "eq") -let coq_refl_equal = lazy(constant path_logic "refl_equal") -let coq_and = lazy(constant path_logic "and") -let coq_not = lazy(constant path_logic "not") -let coq_or = lazy(constant path_logic "or") -let coq_true = lazy(constant path_logic "true") -let coq_false = lazy(constant path_logic "false") -let coq_ex = lazy(constant path_logic "ex") -let coq_I = lazy(constant path_logic "I") - -(* Lists *) -let coq_cons = lazy (constant path_list "cons") -let coq_nil = lazy (constant path_list "nil") - -let coq_pcons = lazy (constant module_refl_path "Pcons") -let coq_pnil = lazy (constant module_refl_path "Pnil") - -let coq_h_step = lazy (constant module_refl_path "h_step") -let coq_pair_step = lazy (constant module_refl_path "pair_step") -let coq_p_left = lazy (constant module_refl_path "P_LEFT") -let coq_p_right = lazy (constant module_refl_path "P_RIGHT") -let coq_p_invert = lazy (constant module_refl_path "P_INVERT") -let coq_p_step = lazy (constant module_refl_path "P_STEP") -let coq_p_nop = lazy (constant module_refl_path "P_NOP") - - -let coq_t_int = lazy (constant module_refl_path "Tint") -let coq_t_plus = lazy (constant module_refl_path "Tplus") -let coq_t_mult = lazy (constant module_refl_path "Tmult") -let coq_t_opp = lazy (constant module_refl_path "Topp") -let coq_t_minus = lazy (constant module_refl_path "Tminus") -let coq_t_var = lazy (constant module_refl_path "Tvar") - -let coq_p_eq = lazy (constant module_refl_path "EqTerm") -let coq_p_leq = lazy (constant module_refl_path "LeqTerm") -let coq_p_geq = lazy (constant module_refl_path "GeqTerm") -let coq_p_lt = lazy (constant module_refl_path "LtTerm") -let coq_p_gt = lazy (constant module_refl_path "GtTerm") -let coq_p_neq = lazy (constant module_refl_path "NeqTerm") -let coq_p_true = lazy (constant module_refl_path "TrueTerm") -let coq_p_false = lazy (constant module_refl_path "FalseTerm") -let coq_p_not = lazy (constant module_refl_path "Tnot") -let coq_p_or = lazy (constant module_refl_path "Tor") -let coq_p_and = lazy (constant module_refl_path "Tand") -let coq_p_imp = lazy (constant module_refl_path "Timp") -let coq_p_prop = lazy (constant module_refl_path "Tprop") - -let coq_proposition = lazy (constant module_refl_path "proposition") -let coq_interp_sequent = lazy (constant module_refl_path "interp_goal_concl") -let coq_normalize_sequent = lazy (constant module_refl_path "normalize_goal") -let coq_execute_sequent = lazy (constant module_refl_path "execute_goal") -let coq_do_concl_to_hyp = lazy (constant module_refl_path "do_concl_to_hyp") -let coq_sequent_to_hyps = lazy (constant module_refl_path "goal_to_hyps") -let coq_normalize_hyps_goal = - lazy (constant module_refl_path "normalize_hyps_goal") - -(* Constructors for shuffle tactic *) -let coq_t_fusion = lazy (constant module_refl_path "t_fusion") -let coq_f_equal = lazy (constant module_refl_path "F_equal") -let coq_f_cancel = lazy (constant module_refl_path "F_cancel") -let coq_f_left = lazy (constant module_refl_path "F_left") -let coq_f_right = lazy (constant module_refl_path "F_right") - -(* Constructors for reordering tactics *) -let coq_step = lazy (constant module_refl_path "step") -let coq_c_do_both = lazy (constant module_refl_path "C_DO_BOTH") -let coq_c_do_left = lazy (constant module_refl_path "C_LEFT") -let coq_c_do_right = lazy (constant module_refl_path "C_RIGHT") -let coq_c_do_seq = lazy (constant module_refl_path "C_SEQ") -let coq_c_nop = lazy (constant module_refl_path "C_NOP") -let coq_c_opp_plus = lazy (constant module_refl_path "C_OPP_PLUS") -let coq_c_opp_opp = lazy (constant module_refl_path "C_OPP_OPP") -let coq_c_opp_mult_r = lazy (constant module_refl_path "C_OPP_MULT_R") -let coq_c_opp_one = lazy (constant module_refl_path "C_OPP_ONE") -let coq_c_reduce = lazy (constant module_refl_path "C_REDUCE") -let coq_c_mult_plus_distr = lazy (constant module_refl_path "C_MULT_PLUS_DISTR") -let coq_c_opp_left = lazy (constant module_refl_path "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_r = lazy (constant module_refl_path "C_MULT_ASSOC_R") -let coq_c_plus_assoc_r = lazy (constant module_refl_path "C_PLUS_ASSOC_R") -let coq_c_plus_assoc_l = lazy (constant module_refl_path "C_PLUS_ASSOC_L") -let coq_c_plus_permute = lazy (constant module_refl_path "C_PLUS_PERMUTE") -let coq_c_plus_sym = lazy (constant module_refl_path "C_PLUS_SYM") -let coq_c_red0 = lazy (constant module_refl_path "C_RED0") -let coq_c_red1 = lazy (constant module_refl_path "C_RED1") -let coq_c_red2 = lazy (constant module_refl_path "C_RED2") -let coq_c_red3 = lazy (constant module_refl_path "C_RED3") -let coq_c_red4 = lazy (constant module_refl_path "C_RED4") -let coq_c_red5 = lazy (constant module_refl_path "C_RED5") -let coq_c_red6 = lazy (constant module_refl_path "C_RED6") -let coq_c_mult_opp_left = lazy (constant module_refl_path "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_reduced = - lazy (constant module_refl_path "C_MULT_ASSOC_REDUCED") -let coq_c_minus = lazy (constant module_refl_path "C_MINUS") -let coq_c_mult_sym = lazy (constant module_refl_path "C_MULT_SYM") - -let coq_s_constant_not_nul = lazy (constant module_refl_path "O_CONSTANT_NOT_NUL") -let coq_s_constant_neg = lazy (constant module_refl_path "O_CONSTANT_NEG") -let coq_s_div_approx = lazy (constant module_refl_path "O_DIV_APPROX") -let coq_s_not_exact_divide = lazy (constant module_refl_path "O_NOT_EXACT_DIVIDE") -let coq_s_exact_divide = lazy (constant module_refl_path "O_EXACT_DIVIDE") -let coq_s_sum = lazy (constant module_refl_path "O_SUM") -let coq_s_state = lazy (constant module_refl_path "O_STATE") -let coq_s_contradiction = lazy (constant module_refl_path "O_CONTRADICTION") -let coq_s_merge_eq = lazy (constant module_refl_path "O_MERGE_EQ") -let coq_s_split_ineq =lazy (constant module_refl_path "O_SPLIT_INEQ") -let coq_s_constant_nul =lazy (constant module_refl_path "O_CONSTANT_NUL") -let coq_s_negate_contradict =lazy (constant module_refl_path "O_NEGATE_CONTRADICT") -let coq_s_negate_contradict_inv =lazy (constant module_refl_path "O_NEGATE_CONTRADICT_INV") - -(* construction for the [extract_hyp] tactic *) -let coq_direction = lazy (constant module_refl_path "direction") -let coq_d_left = lazy (constant module_refl_path "D_left") -let coq_d_right = lazy (constant module_refl_path "D_right") -let coq_d_mono = lazy (constant module_refl_path "D_mono") - -let coq_e_split = lazy (constant module_refl_path "E_SPLIT") -let coq_e_extract = lazy (constant module_refl_path "E_EXTRACT") -let coq_e_solve = lazy (constant module_refl_path "E_SOLVE") - -let coq_decompose_solve_valid = - lazy (constant module_refl_path "decompose_solve_valid") -let coq_do_reduce_lhyps = lazy (constant module_refl_path "do_reduce_lhyps") -let coq_do_omega = lazy (constant module_refl_path "do_omega") - -*) (* \subsection{Construction d'expressions} *) @@ -423,8 +245,8 @@ let mk_and t1 t2 = Term.mkApp (Lazy.force coq_and, [|t1; t2 |]) let mk_or t1 t2 = Term.mkApp (Lazy.force coq_or, [|t1; t2 |]) let mk_not t = Term.mkApp (Lazy.force coq_not, [|t |]) let mk_eq_rel t1 t2 = Term.mkApp (Lazy.force coq_eq, [| - Lazy.force coq_relation; t1; t2 |]) -let mk_inj t = Term.mkApp (Lazy.force coq_inject_nat, [|t |]) + Lazy.force coq_comparison; t1; t2 |]) +let mk_inj t = Term.mkApp (Lazy.force coq_Z_of_nat, [|t |]) let do_left t = @@ -450,16 +272,20 @@ let rec do_list = function | [x] -> x | (x::l) -> do_seq x (do_list l) - let mk_integer n = let rec loop n = - if n=1 then Lazy.force coq_xH else - Term.mkApp ((if n mod 2 = 0 then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/2) |]) in + 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), + [| loop q |]) in - if n = 0 then Lazy.force coq_ZERO - else Term.mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG), - [| loop (abs n) |]) + if n = Bigint.zero then Lazy.force coq_Z0 + else + if Bigint.is_strictly_pos n then + Term.mkApp (Lazy.force coq_Zpos, [| loop n |]) + else + Term.mkApp (Lazy.force coq_Zneg, [| loop (Bigint.neg n) |]) let mk_Z = mk_integer diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4 index 386f7f28..7cfc50f8 100644 --- a/contrib/romega/g_romega.ml4 +++ b/contrib/romega/g_romega.ml4 @@ -10,6 +10,6 @@ open Refl_omega -TACTIC EXTEND ROmega - [ "ROmega" ] -> [ total_reflexive_omega_tactic ] +TACTIC EXTEND romelga + [ "romega" ] -> [ total_reflexive_omega_tactic ] END diff --git a/contrib/romega/omega2.ml b/contrib/romega/omega2.ml deleted file mode 100644 index 91aefc60..00000000 --- a/contrib/romega/omega2.ml +++ /dev/null @@ -1,675 +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 - -let flat_map f = - let rec flat_map_f = function - | [] -> [] - | x :: l -> f x @ flat_map_f l - in - flat_map_f - -let pp i = print_int i; print_newline (); flush stdout - -let debug = ref false - -let filter = List.partition - -let push v l = l := v :: !l - -let rec pgcd x y = if y = 0 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 >=0 , b > 0 with - | true,true -> a / b - | false,false -> a / b - | true, false -> (a-1) / b - 1 - | false,true -> (a+1) / b - 1 - -type coeff = {c: int ; 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: int } - -type state_action = { - st_new_eq : afine; - st_def : afine; - st_orig : afine; - st_coef : int; - st_var : int } - -type action = - | DIVIDE_AND_APPROX of afine * afine * int * int - | NOT_EXACT_DIVIDE of afine * int - | FORGET_C of int - | EXACT_DIVIDE of afine * int - | SUM of int * (int * afine) * (int * 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 * int - | CONSTANT_NUL of int - | CONSTANT_NEG of int * int - | SPLIT_INEQ of afine * (int * action list) * (int * action list) - | WEAKEN of int * int - -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 < 0 then "- " else if not_first then "+ " else ""); - let c = abs f.c in - if c = 1 then - Printf.printf "%s " (print_var f.v) - else - Printf.printf "%d %s " c (print_var f.v); - true) - false l - in - if e > 0 then - Printf.printf "+ %d " e - else if e < 0 then - Printf.printf "- %d " (abs e) - -let rec trace_length l = - let action_length accu = function - | SPLIT_INEQ (_,(_,l1),(_,l2)) -> - accu + 1 + trace_length l1 + trace_length l2 - | _ -> accu + 1 in - List.fold_left action_length 0 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} -> - print_int id; print_string ": "; - display_eq print_var (e,c); print_string (operator_of_eq b); - print_string "0\n") - 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 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 %d and the constant coefficient is \ - rounded by substracting %d.\n" e1.id k d - | NOT_EXACT_DIVIDE (e,k) -> - Printf.printf - "Constant in equation E%d is not divisible by the pgcd \ - %d of its other coefficients.\n" e.id k - | EXACT_DIVIDE (e,k) -> - Printf.printf - "Equation E%d is divided by the pgcd \ - %d of its coefficients.\n" e.id k - | WEAKEN (e,k) -> - Printf.printf - "To ensure a solution in the dark shadow \ - the equation E%d is weakened by %d.\n" e k - | SUM (e,(c1,e1),(c2,e2)) -> - Printf.printf - "We state %s E%d = %d %s E%d + %d %s E%d.\n" - (kind_of e1.kind) e c1 (kind_of e1.kind) e1.id c2 - (kind_of e2.kind) e2.id - | STATE { st_new_eq = e; st_coef = x} -> - Printf.printf "We define a new equation %d :" e.id; - display_eq print_var (e.body,e.constant); - print_string (operator_of_eq e.kind); print_string " 0\n" - | HYP e -> - Printf.printf "We define %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 implie a contradiction on their \ - constant factors.\n" e1.id e2.id - | NEGATE_CONTRADICT(e1,e2,b) -> - Printf.printf - "Eqations 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 %d=0.\n" e k - | CONSTANT_NEG(e,k) -> - Printf.printf "equation E%d states %d >= 0.\n" e 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 "XX%d" v - -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=0 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 -> -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 = 0 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 = 1 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 =0 then [] else begin - add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE - end - | DISE -> - if x <> 0 then [] else begin - add_event (CONSTANT_NUL id); raise UNSOLVABLE - end - | INEQ -> - if x >= 0 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 <> 0 then begin - add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE - end else if eq_flag=DISE & x mod gcd <> 0 then begin - add_event (FORGET_C eq.id); [] - end else if gcd <> 1 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=1 then -f.c else if c_unite= -1 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,(1,eq1),(coeff,eq2))); res - with CHOPVAR -> eq1 - -let omega_mod a b = a - b * floor_div (2 * a + b) (2 * 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 + 1 in - let new_eq = - { constant = omega_mod original.constant m; - body = {c= -m;v=sigma} :: - map_eq_linear (fun a -> omega_mod a m) original.body; - id = new_eq_id (); kind = EQUA } in - let definition = - { constant = - floor_div (2 * original.constant + m) (2 * m); - body = map_eq_linear (fun a -> - floor_div (2 * a + m) (2 * 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 = - flat_map (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) - l1 in - let inequations = - flat_map (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 - (flat_map (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other, - flat_map (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 = 1) 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 = 0 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 < 0 -> 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 < 0 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 0 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 >= 0 then (not_occ,((f.c,eq) :: below),over) - else (not_occ,below,((-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 - 1) * (b - 1) 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 = flat_map normalize system in - let eqs,ineqs = filter (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} -> - if List.mem e.id relie_on then depend 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,_ = filter (fun e -> e.kind = DISE) ineqs in - let normal = function - | ({body=f::_} as e) when f.c < 0 -> 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 -> - if e.kind <> EQUA then pp 9999; - 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 = filter (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 - 1} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear (fun x -> -x) de.body; - constant = - de.constant - 1} 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 = flat_map normalize system in - let eqs,ineqs = filter (fun e -> e.kind=EQUA) system in - let dise,ine = filter (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 = filter (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,_ = filter (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 = filter (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 ())) diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml index ef68c587..285fc0ca 100644 --- a/contrib/romega/refl_omega.ml +++ b/contrib/romega/refl_omega.ml @@ -7,7 +7,8 @@ *************************************************************************) open Const_omega - +module OmegaSolver = Omega.MakeOmegaSolver (Bigint) +open OmegaSolver (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) @@ -25,7 +26,7 @@ let (>>) = Tacticals.tclTHEN let list_index t = let rec loop i = function - | (u::l) -> if u = t then i else loop (i+1) l + | (u::l) -> if u = t then i else loop (succ i) l | [] -> raise Not_found in loop 0 @@ -101,7 +102,7 @@ type occurence = {o_hyp : Names.identifier; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = (* integer *) - | Oint of int + | Oint of Bigint.bigint (* recognized binary and unary operations *) | Oplus of oformula * oformula | Omult of oformula * oformula @@ -139,7 +140,7 @@ and oequation = { 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: Omega2.afine (* la fonction normalisée *) + e_omega: afine (* la fonction normalisée *) } (* \subsection{Proof context} @@ -172,7 +173,7 @@ type environment = { type solution = { s_index : int; s_equa_deps : int list; - s_trace : Omega2.action list } + s_trace : action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) type solution_tree = @@ -203,8 +204,8 @@ let new_environment () = { } (* Génération d'un nom d'équation *) -let new_eq_id env = - env.cnt_connectors <- env.cnt_connectors + 1; env.cnt_connectors +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 @@ -215,21 +216,36 @@ 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" + [] -> Printf.printf " ===============================\n\n" | t :: l -> - Printf.printf "(%c%02d) : " c i; - Pp.ppnl (Printer.prterm t); + Printf.printf " (%c%02d) := " c i; + Pp.ppnl (Printer.pr_lconstr t); Pp.flush_all (); - loop c (i+1) l in - Printf.printf "PROPOSITIONS :\n\n"; loop 'P' 0 env.props; - Printf.printf "TERMES :\n\n"; loop 'V' 0 env.terms + 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_id = let cpt = ref 0 in function () -> incr cpt; !cpt + +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_id i = Printf.sprintf "O%d" i + +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) *) @@ -237,12 +253,12 @@ let display_omega_id i = Printf.sprintf "O%d" i let intern_omega env t = begin try List.assoc t env.om_vars with Not_found -> - let v = new_omega_id () in + 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 Omega. Cas ou la - variable est crée par Omega et ou il faut la lier après coup a un atome +(* 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 @@ -281,7 +297,7 @@ 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.Omega2.id in + let id = e.e_omega.id in try let _ = Hashtbl.find env.equations id in () with Not_found -> Hashtbl.add env.equations id e @@ -292,7 +308,7 @@ let get_equation env id = (* Affichage des termes réifiés *) let rec oprint ch = function - | Oint n -> Printf.fprintf ch "%d" n + | 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 @@ -304,7 +320,7 @@ let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> let connector = match comp with - Eq -> "=" | Leq -> "=<" | Geq -> ">=" + Eq -> "=" | Leq -> "<=" | Geq -> ">=" | Gt -> ">" | Lt -> "<" | Neq -> "!=" in Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 | Ptrue -> Printf.fprintf ch "TT" @@ -331,12 +347,12 @@ let rec weight env = function let omega_of_oformula env kind = let rec loop accu = function | Oplus(Omult(v,Oint n),r) -> - loop ({Omega2.v=intern_omega env v; Omega2.c=n} :: accu) r + loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> - let id = new_omega_id () in + let id = new_omega_eq () in (*i tag_equation name id; i*) - {Omega2.kind = kind; Omega2.body = List.rev accu; - Omega2.constant = n; Omega2.id = id} + {kind = kind; body = List.rev accu; + constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] @@ -351,10 +367,10 @@ let reified_of_atom env i = let rec oformula_of_omega env af = let rec loop = function - | ({Omega2.v=v; Omega2.c=n}::r) -> + | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) - | [] -> Oint af.Omega2.constant in - loop af.Omega2.body + | [] -> Oint af.constant in + loop af.body let app f v = mkApp(Lazy.force f,v) @@ -429,7 +445,7 @@ let reified_of_proposition env f = let reified_of_omega env body constant = let coeff_constant = app coq_t_int [| mk_Z constant |] in - let mk_coeff {Omega2.c=c; Omega2.v=v} t = + let mk_coeff {c=c; v=v} t = let coef = app coq_t_mult [| reified_of_formula env (unintern_omega env v); @@ -441,7 +457,7 @@ let reified_of_omega env body c = begin try reified_of_omega env body c with e -> - Omega2.display_eq display_omega_id (body,c); raise e + display_eq display_omega_var (body,c); raise e end (* \section{Opérations sur les équations} @@ -475,7 +491,7 @@ let rec scalar n = function 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(-n)) + 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) -> @@ -496,12 +512,12 @@ let rec negate = function | 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 (-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(-1)) - | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(-i) + 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" @@ -511,10 +527,10 @@ let rec norm l = (List.length l) (* \subsubsection{Version avec coefficients} *) let rec shuffle_path k1 e1 k2 e2 = let rec loop = function - (({Omega2.c=c1;Omega2.v=v1}::l1) as l1'), - (({Omega2.c=c2;Omega2.v=v2}::l2) as l2') -> + (({c=c1;v=v1}::l1) as l1'), + (({c=c2;v=v2}::l2) as l2') -> if v1 = v2 then - if k1*c1 + k2 * c2 = 0 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) ) @@ -522,9 +538,9 @@ let rec shuffle_path k1 e1 k2 e2 = Lazy.force coq_f_left :: loop(l1,l2')) else ( Lazy.force coq_f_right :: loop(l1',l2)) - | ({Omega2.c=c1;Omega2.v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> Lazy.force coq_f_left :: loop(l1,[]) - | [],({Omega2.c=c2;Omega2.v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> Lazy.force coq_f_right :: loop([],l2) | [],[] -> flush stdout; [] in mk_shuffle_list (loop (e1,e2)) @@ -543,7 +559,7 @@ let rec shuffle env (t1,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_sym], Oplus(t2,t1) + 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 @@ -553,7 +569,7 @@ let rec shuffle env (t1,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_sym], Oplus(t2,t1) + do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) else do_list [],Oplus(t1,t2) (* \subsection{Fusion avec réduction} *) @@ -561,11 +577,11 @@ let rec shuffle env (t1,t2) = let shrink_pair f1 f2 = begin match f1,f2 with Oatom v,Oatom _ -> - Lazy.force coq_c_red1, Omult(Oatom v,Oint 2) + 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 1)) + 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 1)) + 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 -> @@ -577,7 +593,7 @@ let shrink_pair f1 f2 = let reduce_factor = function Oatom v -> - let r = Omult(Oatom v,Oint 1) in + 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) -> @@ -588,7 +604,7 @@ let reduce_factor = function [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) | t -> Util.error "reduce_factor.1" -(* \subsection{Réordonancement} *) +(* \subsection{Réordonnancement} *) let rec condense env = function Oplus(f1,(Oplus(f2,r) as t)) -> @@ -602,7 +618,7 @@ let rec condense env = function let tac',t' = condense env t in [do_both (do_list tac) (do_list tac')], Oplus(f,t') end - | (Oplus(f1,Oint n) as t) -> + | Oplus(f1,Oint n) -> let tac,f1' = reduce_factor f1 in [do_left (do_list tac)],Oplus(f1',Oint n) | Oplus(f1,f2) -> @@ -618,13 +634,13 @@ let rec condense env = function | (Oint _ as t)-> [],t | t -> let tac,t' = reduce_factor t in - let final = Oplus(t',Oint 0) 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 0),r) -> + 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) -> @@ -652,7 +668,7 @@ let rec reduce env = function 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_sym; tac] + t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] | _ -> Oufo t, Lazy.force coq_c_nop end | Oopp t -> @@ -681,25 +697,36 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = 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)) Omega2.EQUA - | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) Omega2.DISE - | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) Omega2.INEQ - | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) Omega2.INEQ + | 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 (-1)),Oopp o1)) - Omega2.INEQ + 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 (-1)),Oopp o2)) - Omega2.INEQ + 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 is_scalar t = + let rec aux t = match destructurate t with + | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 + | Kapp(("Zopp"|"Zsucc"),[t]) -> aux t + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize_number t in true + | _ -> false in + try aux t with _ -> false + let rec oformula_of_constr env t = try match destructurate t with | Kapp("Zplus",[t1;t2]) -> binop env (fun x y -> Oplus(x,y)) t1 t2 - | Kapp("Zminus",[t1;t2]) ->binop env (fun x y -> Ominus(x,y)) t1 t2 - | Kapp("Zmult",[t1;t2]) ->binop env (fun x y -> Omult(x,y)) t1 t2 + | Kapp("Zminus",[t1;t2]) -> binop env (fun x y -> Ominus(x,y)) t1 t2 + | Kapp("Zmult",[t1;t2]) when is_scalar t1 or is_scalar t2 -> + binop env (fun x y -> Omult(x,y)) t1 t2 + | Kapp("Zopp",[t]) -> Oopp(oformula_of_constr env t) + | Kapp("Zsucc",[t]) -> Oplus(oformula_of_constr env t, Oint one) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> begin try Oint(recognize_number t) with _ -> Oatom (add_reified_atom t env) end @@ -715,7 +742,7 @@ and binop env c t1 t2 = and binprop env (neg2,depends,origin,path) add_to_depends neg1 gl c t1 t2 = - let i = new_eq_id env in + 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 @@ -775,13 +802,14 @@ let reify_gl env gl = let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in if !debug then begin - Printf.printf "CONCL: "; pprint stdout t_concl; Printf.printf "\n" + 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); + Printf.printf " %s: " (Names.string_of_id i); pprint stdout t'; Printf.printf "\n" end; @@ -859,11 +887,11 @@ let display_depend = function let display_systems syst_list = let display_omega om_e = - Printf.printf "%d : %a %s 0\n" - om_e.Omega2.id - (fun _ -> Omega2.display_eq display_omega_id) - (om_e.Omega2.body, om_e.Omega2.constant) - (Omega2.operator_of_eq om_e.Omega2.kind) in + 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 (); @@ -874,12 +902,12 @@ let display_systems syst_list = (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" + 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 "false") in + (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = - Printf.printf "=SYSTEME==================================\n"; + Printf.printf "=SYSTEM===================================\n"; List.iter display_equation syst in List.iter display_system syst_list @@ -889,8 +917,8 @@ let display_systems syst_list = let rec hyps_used_in_trace = function | act :: l -> begin match act with - | Omega2.HYP e -> e.Omega2.id :: hyps_used_in_trace l - | Omega2.SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | 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 @@ -903,11 +931,11 @@ let rec hyps_used_in_trace = function let rec variable_stated_in_trace = function | act :: l -> begin match act with - | Omega2.STATE action -> + | STATE action -> (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) (*i coef: int, var:int i*) action :: variable_stated_in_trace l - | Omega2.SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> variable_stated_in_trace act1 @ variable_stated_in_trace act2 | _ -> variable_stated_in_trace l end @@ -922,10 +950,10 @@ 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 = - List.sort (fun x y -> x.Omega2.st_var - y.Omega2.st_var) (loop tree) in + List.sort (fun x y -> Pervasives.(-) x.st_var y.st_var) (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.Omega2.st_def in + 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 @@ -936,8 +964,8 @@ let add_stated_equations env tree = * 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.Omega2.st_var; - (v, term_to_generalize,term_to_reify,st.Omega2.st_def.Omega2.id) in + 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 @@ -950,7 +978,7 @@ let rec get_eclatement env = function | [] -> [] let select_smaller l = - let comp (_,x) (_,y) = List.length x - List.length y in + 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 = @@ -968,11 +996,15 @@ let rec equas_of_solution_tree = function | Leaf s -> s.s_equa_deps +(* Because of really_useful_prop, decidable formulas such as Pfalse + and Ptrue are moved to Pprop, thus breaking the decidability check + in ReflOmegaCore.concl_to_hyp... *) + let really_useful_prop l_equa c = let rec real_of = function Pequa(t,_) -> t - | Ptrue -> app coq_true [||] - | Pfalse -> app coq_false [||] + | 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|] @@ -982,7 +1014,7 @@ let really_useful_prop l_equa c = let rec loop c = match c with Pequa(_,e) -> - if List.mem e.e_omega.Omega2.id l_equa then Some c else None + if List.mem e.e_omega.id l_equa then Some c else None | Ptrue -> None | Pfalse -> None | Pnot t1 -> @@ -1041,9 +1073,9 @@ let find_path {o_hyp=id;o_path=p} env = 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 (i+1) l + | None -> loop_id (succ i) l end - | _ :: l -> loop_id (i+1) l + | _ :: l -> loop_id (succ i) l | [] -> failwith "find_path" in loop_id 0 env @@ -1062,59 +1094,59 @@ let get_hyp env_hyp i = let replay_history env env_hyp = let rec loop env_hyp t = match t with - | Omega2.CONTRADICTION (e1,e2) :: l -> - let trace = mk_nat (List.length e1.Omega2.body) in + | 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.Omega2.id); - mk_nat (get_hyp env_hyp e2.Omega2.id) |]) - | Omega2.DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> + [| 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, [| mk_Z k; mk_Z d; - reified_of_omega env e2.Omega2.body e2.Omega2.constant; - mk_nat (List.length e2.Omega2.body); - loop env_hyp l; mk_nat (get_hyp env_hyp e1.Omega2.id) |]) - | Omega2.NOT_EXACT_DIVIDE (e1,k) :: l -> - let e2_constant = Omega2.floor_div e1.Omega2.constant k in - let d = e1.Omega2.constant - e2_constant * k in - let e2_body = Omega2.map_eq_linear (fun c -> c / k) e1.Omega2.body in + 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, [|mk_Z k; mk_Z d; reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); - mk_nat (get_hyp env_hyp e1.Omega2.id)|]) - | Omega2.EXACT_DIVIDE (e1,k) :: l -> + mk_nat (get_hyp env_hyp e1.id)|]) + | EXACT_DIVIDE (e1,k) :: l -> let e2_body = - Omega2.map_eq_linear (fun c -> c / k) e1.Omega2.body in - let e2_constant = Omega2.floor_div e1.Omega2.constant k in + 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, [|mk_Z 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.Omega2.id)|]) - | (Omega2.MERGE_EQ(e3,e1,e2)) :: l -> - let n1 = get_hyp env_hyp e1.Omega2.id and n2 = get_hyp env_hyp e2 in + 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.Omega2.body); + [| mk_nat (List.length e1.body); mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) - | Omega2.SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.Omega2.id - and n2 = get_hyp env_hyp e2.Omega2.id in - let trace = shuffle_path k1 e1.Omega2.body k2 e2.Omega2.body in + | 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, [| mk_Z k1; mk_nat n1; mk_Z k2; mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) - | Omega2.CONSTANT_NOT_NUL(e,k) :: l -> + | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) - | Omega2.CONSTANT_NEG(e,k) :: l -> + | CONSTANT_NEG(e,k) :: l -> mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) - | Omega2.STATE {Omega2.st_new_eq=new_eq; Omega2.st_def =def; - Omega2.st_orig=orig; Omega2.st_coef=m; - Omega2.st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.Omega2.id - and n2 = get_hyp env_hyp def.Omega2.id in + | 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 @@ -1123,24 +1155,24 @@ let replay_history env env_hyp = let trace,_ = normalize_linear_term env body in mkApp (Lazy.force coq_s_state, [| mk_Z m; trace; mk_nat n1; mk_nat n2; - loop (CCEqua new_eq.Omega2.id :: env_hyp) l |]) - | Omega2.HYP _ :: l -> loop env_hyp l - | Omega2.CONSTANT_NUL e :: l -> + 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) |]) - | Omega2.NEGATE_CONTRADICT(e1,e2,b) :: l -> + | NEGATE_CONTRADICT(e1,e2,b) :: l -> mkApp (Lazy.force coq_s_negate_contradict, - [| mk_nat (get_hyp env_hyp e1.Omega2.id); - mk_nat (get_hyp env_hyp e2.Omega2.id) |]) - | Omega2.SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> - let i = get_hyp env_hyp e.Omega2.id in + [| 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.Omega2.body); mk_nat i; r1 ; r2 |]) - | (Omega2.FORGET_C _ | Omega2.FORGET _ | Omega2.FORGET_I _) :: l -> + [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) + | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l - | (Omega2.WEAKEN _ ) :: l -> failwith "not_treated" + | (WEAKEN _ ) :: l -> failwith "not_treated" | [] -> failwith "no contradiction" in loop env_hyp @@ -1171,7 +1203,7 @@ and decompose_tree_hyps trace env ctxt = function 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.Omega2.id :: ctxt) l in + (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list full_path; cont |] @@ -1190,15 +1222,15 @@ let resolution env full_reified_goal systems_list = let index = !num in let system = List.map (fun eq -> eq.e_omega) list_eq in let trace = - Omega2.simplify_strong - ((fun () -> new_eq_id env),new_omega_id,display_omega_id) + 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; - Omega2.display_action display_omega_id trace; + display_action display_omega_var trace; print_string "\n Depend :"; List.iter (fun i -> Printf.printf " %d" i) vars; print_string "\n Split points :"; @@ -1236,7 +1268,7 @@ let resolution env full_reified_goal systems_list = let rec loop i = function var :: l -> let t = get_reified_atom env var in - Hashtbl.add env.real_indices var i; t :: loop (i+1) l + 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 coq_Z) basic_env in @@ -1262,7 +1294,7 @@ let resolution env full_reified_goal systems_list = (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent - [| env_props_reified;env_terms_reified;reified_concl;reified_goal |] in + [| 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) @@ -1286,20 +1318,26 @@ let resolution env full_reified_goal systems_list = Tactics.change_in_concl None reified >> Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> show_goal >> - Tactics.normalise_in_concl >> + 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 = - if !Options.v7 then Util.error "ROmega does not work in v7 mode"; + 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 begin - display_systems systems_list - end; + if !debug then display_systems systems_list; resolution env full_reified_goal systems_list gl - with Omega2.NO_CONTRADICTION -> Util.error "ROmega can't solve this system" + 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 new file mode 100644 index 00000000..f4b24d4b --- /dev/null +++ b/contrib/rtauto/Bintree.v @@ -0,0 +1,498 @@ +(************************************************************************) +(* 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 8881 2006-05-31 18:16:34Z jforest $ *) + +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 Prect : forall P : positive -> Type, + P 1 -> + (forall n : positive, P n -> P (Psucc n)) -> forall p : positive, P p. +intros P H1 Hsucc n; induction n. +rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption. +rewrite <- plus_iter_xO; apply iterate_add; assumption. +assumption. +Qed. + +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 (m<>m) (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 (m<>n) 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 new file mode 100644 index 00000000..98fca90f --- /dev/null +++ b/contrib/rtauto/Rtauto.v @@ -0,0 +1,398 @@ +(************************************************************************) +(* 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/field/Field.v b/contrib/rtauto/g_rtauto.ml4 index 7b48e275..d7bb6e31 100644 --- a/contrib/field/Field.v +++ b/contrib/rtauto/g_rtauto.ml4 @@ -6,10 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field.v,v 1.6.2.1 2004/07/16 19:30:09 herbelin Exp $ *) +(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*) -Require Export Field_Compl. -Require Export Field_Theory. -Require Export Field_Tactic. +(*i camlp4deps: "parsing/grammar.cma" i*) + +TACTIC EXTEND rtauto + [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ] +END -(* Command declarations are moved to the ML side *)
\ No newline at end of file diff --git a/contrib/rtauto/proof_search.ml b/contrib/rtauto/proof_search.ml new file mode 100644 index 00000000..98643e0f --- /dev/null +++ b/contrib/rtauto/proof_search.ml @@ -0,0 +1,546 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..eb11aeae --- /dev/null +++ b/contrib/rtauto/proof_search.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..a1f5e5aa --- /dev/null +++ b/contrib/rtauto/refl_tauto.ml @@ -0,0 +1,337 @@ +(************************************************************************) +(* 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 9154 2006-09-20 17:18:18Z corbinea $ *) + +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 could'nt 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 new file mode 100644 index 00000000..480dbb30 --- /dev/null +++ b/contrib/rtauto/refl_tauto.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..074f6ef7 --- /dev/null +++ b/contrib/setoid_ring/ArithRing.v @@ -0,0 +1,60 @@ +(************************************************************************) +(* 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) + | _ => 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 new file mode 100644 index 00000000..50902004 --- /dev/null +++ b/contrib/setoid_ring/BinList.v @@ -0,0 +1,93 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..a944ba5f --- /dev/null +++ b/contrib/setoid_ring/Field.v @@ -0,0 +1,10 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..aad3a580 --- /dev/null +++ b/contrib/setoid_ring/Field_tac.v @@ -0,0 +1,405 @@ +(************************************************************************) +(* 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 := + match type of lemma with + | context [ + (* PCond _ _ _ _ _ _ _ _ _ _ _ -> *) + (@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 ?ceqb _] => + compute_assertion vlmp_eq vlmp + (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe); + (assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq) + || fail "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 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) := + match goal with [|- ?G] => field_lookup Field_simplify [] rl [G] end. + +Tactic Notation (at level 0) + "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := + match goal with [|- ?G] => field_lookup Field_simplify [lH] rl [G] end. + +Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= + let G := getGoal 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 := getGoal 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 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 := getGoal in field_lookup FIELD [] [G]. + +Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := + let G := getGoal 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 := getGoal in field_lookup FIELD_SIMPL [] [G]. + +Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := + let G := getGoal 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 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 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 rk + ltac:(fun arth ext_r morph p_spec s_spec f => f afth ext_r morph p_spec s_spec). + +Ltac field_lemmas set ext inv_m fspec pspec sspec rk := + let simpl_eq_lemma := + match pspec with + | None => constr:(Field_simplify_eq_correct) + | Some _ => constr:(Field_simplify_eq_pow_correct) + end in + let simpl_eq_in_lemma := + match pspec with + | None => constr:(Field_simplify_eq_in_correct) + | Some _ => constr:(Field_simplify_eq_pow_in_correct) + end in + let rw_lemma := + match pspec with + | None => constr:(Field_rw_correct) + | Some _ => constr:(Field_rw_pow_correct) + end in + field_elements set ext fspec pspec sspec rk + ltac:(fun afth ext_r morph p_spec s_spec => + match p_spec with + | mkhypo ?pp_spec => match s_spec with + | mkhypo ?ss_spec => + let field_simpl_eq_ok := + constr:(simpl_eq_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_simpl_ok := + constr:(rw_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_simpl_eq_in := + constr:(simpl_eq_in_lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec) in + let field_ok := + constr:(Field_correct set ext_r inv_m afth morph pp_spec ss_spec) in + let cond1_ok := + constr:(Pcond_simpl_gen set ext_r afth morph pp_spec) in + let cond2_ok := + constr:(Pcond_simpl_complete set ext_r afth morph pp_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 2 "bad sign specification" + end + | _ => fail 1 "bad power specification" + end). + diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v new file mode 100644 index 00000000..ea8421cf --- /dev/null +++ b/contrib/setoid_ring/Field_theory.v @@ -0,0 +1,1859 @@ +(************************************************************************) +(* 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). + + + (* Usefull 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 ropp req phi get_sign. + +Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow). +Notation Nnorm := (norm_subst cO cI cadd cmul csub copp ceqb). + +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 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 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 |- *. + 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) : 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. + +(* 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;[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. 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 + mk_linear (NPEmul (num x) (num y)) + (NPEmul (denum x) (denum y)) + (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 + mk_linear (NPEmul (num x) (denum y)) + (NPEmul (denum x) (num y)) + (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). rewrite H1. rewrite Hp;ring. ring. + reflexivity. + intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + rewrite Hp;ring. reflexivity. 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. + apply Hrec1. + apply PCond_app_inv_l with (1 := Hcond). + apply Hrec2. + apply PCond_app_inv_r with (1 := Hcond). + 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. + apply Hrec1. + specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. + apply PCond_app_inv_l with (1 := Hcond1). + apply PCond_cons_inv_l with (1:=Hcond). + 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. +apply rdiv4; 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. +apply rdiv7; auto. +apply PCond_cons_inv_l with ( 1 := HH ). + +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). +intro Hp;apply (pow_pos_not_0 Hdiff p). +rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). + apply pow_pos_not_0;trivial. ring [Hp]. reflexivity. +apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. +rewrite IHp;reflexivity. +rewrite <- rdiv4;trivial. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. +rewrite IHp;reflexivity. +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 |- *. + apply PCond_app_inv_l with (1 := Hcond). + rewrite Fnorm_FEeval_PEeval in |- *. + 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). + +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 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 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 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 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 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 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 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. 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. 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_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ 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. 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. 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_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ 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 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. +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 new file mode 100644 index 00000000..bbdcd443 --- /dev/null +++ b/contrib/setoid_ring/InitialRing.v @@ -0,0 +1,581 @@ +(************************************************************************) +(* 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. + +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. + + Lemma Zeqb_ok : forall x y, Zeq_bool x y = true -> x = y. + Proof. + intros x y. + assert (H := Zcompare_Eq_eq x y);unfold Zeq_bool; + destruct (Zcompare x y);intros H1;auto;discriminate H1. + 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 ropp req gen_phiZ get_signZ. + Proof. + constructor. + destruct c;intros;try discriminate. + injection H;clear H;intros H1;subst c'. + simpl;rrefl. + 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 0 1 radd rmul rsub ropp req 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 0 1 radd rmul rsub ropp req 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; repeat rewrite same_genZ. + assert (H1 := Zeqb_ok 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 Zsth 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 0 1 radd rmul rsub ropp req 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. + + (* syntaxification of constants in an abstract ring: + the inverse of gen_phiPOS + Why we do not reconnize only rI ?????? *) + 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 => NotConstant + | 1%positive => 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 => NotConstant + | 1%positive => NotConstant + | ?p => constr:(xI p) + end + | _ => NotConstant + end in + inv_cst t. + +(* 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 => 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 => NotConstant + | ?p => constr:(Zneg p) + end + | _ => + match inv_gen_phi_pos rI add mul t with + NotConstant => NotConstant + | ?p => constr:(Zpos p) + end + end. + +(* A simpl tactic reconninzing nothing *) + 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 _ _ _ _ _ _ _ => + fail 1 "an almost ring cannot be abstract" + | _ => 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 default_sign_spec morph := + 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 => + constr:(mkhypo (@get_sign_None_th R ropp req C phi)) + | _ => fail 1 "ring anomaly : default_sign_spec" + end. + +Ltac gen_ring_sign set rspec morph sspec rk := + match sspec with + | None => + match rk with + | Abstract => + match type of rspec with + | @ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req => + constr:(mkhypo (@get_signZ_th R rO rI radd rmul ropp req set)) + | _ => default_sign_spec morph + end + | _ => default_sign_spec morph + end + | Some ?t => constr:(t) + end. + + +Ltac ring_elements set ext rspec pspec sspec 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 " ici" + 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 set rspec morph sspec rk in + fun f => f arth ext_r morph p_spec s_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 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 rk + ltac:(fun arth ext_r morph p_spec s_spec => + match p_spec with + | mkhypo ?pp_spec => + match s_spec with + | mkhypo ?ps_spec => + let lemma1 := + constr:(ring_correct set ext_r arth morph pp_spec) in + let lemma2 := + constr:(gen_lemma2 _ _ _ _ _ _ _ _ set ext_r arth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec + _ ps_spec) in + fun f => f arth ext_r morph lemma1 lemma2 + | _ => fail 2 "bad sign specification" + end + | _ => fail 1 "bad power specification" + end). + +(* Tactic for constant *) +Ltac isnatcst t := + match t with + O => true + | S ?p => isnatcst p + | _ => 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 + | _ => 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 => 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 + (* *) + | _ => false + end. + + + + + diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v new file mode 100644 index 00000000..ae067a8a --- /dev/null +++ b/contrib/setoid_ring/NArithRing.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* 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 + | _ => 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 new file mode 100644 index 00000000..d0512dff --- /dev/null +++ b/contrib/setoid_ring/RealField.v @@ -0,0 +1,133 @@ +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 new file mode 100644 index 00000000..1a4e1cc7 --- /dev/null +++ b/contrib/setoid_ring/Ring.v @@ -0,0 +1,44 @@ +(************************************************************************) +(* 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 + | _ => 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 new file mode 100644 index 00000000..95b037e3 --- /dev/null +++ b/contrib/setoid_ring/Ring_base.v @@ -0,0 +1,16 @@ +(************************************************************************) +(* 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. *) + +Declare ML Module "newring". +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 new file mode 100644 index 00000000..945f6c68 --- /dev/null +++ b/contrib/setoid_ring/Ring_equiv.v @@ -0,0 +1,74 @@ +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 new file mode 100644 index 00000000..b79f2fe2 --- /dev/null +++ b/contrib/setoid_ring/Ring_polynom.v @@ -0,0 +1,1696 @@ +(************************************************************************) +(* 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. + + + (* 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 0 1 radd rmul rsub ropp req 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 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: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 [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 <- 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 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 Pplus_comm; rewrite jump_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) (List.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. 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: list 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: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. + + (** 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. trivial. Esimpl. 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. 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 Mon := + match P with + | Pc c => if (c ?=! cI) then Some mon0 else None + | Pinj j P => + match mon_of_pol P with + | None => None + | Some m => Some (mkZmon j m) + end + | PX P i Q => + if Peq Q P0 then + match mon_of_pol P with + | None => None + | Some m => Some (mkVmon i m) + end + else None + end. + + Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (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, Mphi l m == P@l. + Proof. + induction P;simpl;intros;Esimpl. + assert (H1 := (morph_eq CRmorph) c cI). + destruct (c ?=! cI). + inversion H;rewrite H1;trivial;Esimpl. + discriminate. + generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate. + inversion H0. + rewrite mkZmon_ok;simpl;auto. + 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);intros. + inversion H1. + rewrite mkVmon_ok;simpl. + rewrite H;trivial;Esimpl. rewrite IHP1;trivial;Esimpl. 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. 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 ropp req phi 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 (get_sign_spec.(sign_spec) _ H). 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 (get_sign_spec.(sign_spec) _ H). + 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 new file mode 100644 index 00000000..7419f184 --- /dev/null +++ b/contrib/setoid_ring/Ring_tac.v @@ -0,0 +1,356 @@ +Set Implicit Arguments. +Require Import Setoid. +Require Import BinPos. +Require Import Ring_polynom. +Require Import BinList. +Require Import InitialRing. +Declare ML Module "newring". + + +(* 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]). *) + +Ltac getGoal := + match goal with + | |- ?G => G + end. + +(********************************************************************) +(* 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 := + match Cst t with + | InitialRing.NotConstant => + match t with + | (radd ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEadd e1 e2) + | (rmul ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEmul e1 e2) + | (rsub ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(PEsub e1 e2) + | (ropp ?t1) => + let e1 := mkP t1 in constr:(PEopp e1) + | (rpow ?t1 ?n) => + match CstPow n with + | InitialRing.NotConstant => + let p := Find_at t fv in constr:(PEX C p) + | ?c => let e1 := mkP t1 in constr:(PEpow e1 c) + end + | _ => + let p := Find_at t fv in constr:(PEX C p) + end + | ?c => constr:(PEc c) + end + 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 FV_hypo_tac mkFV req lH := + let R := match type of req with ?R -> _ => R end 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 "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 Coeffs := + match type of lemma2 with + | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] => + (fun f => f cO cI cadd cmul csub copp ceqb) + | _ => fail 1 "ring_simplify anomaly: bad correctness lemma" + end 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); + Coeffs ltac:(fun cO cI cadd cmul csub copp ceqb => + compute_assertion vlmp_eq vlmp + (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe); + assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq) + || fail "type error when build the rewriting lemma"; + RW_tac rr_lemma; + try clear rr_lemma vlmp_eq vlmp vlpe) 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. + +Tactic Notation (at level 0) "ring" := + let G := getGoal in ring_lookup Ring_gen [] [G]. + +Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" := + let G := getGoal 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(); + match goal with + | [|- l = ?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() + | _ => fail 1 "ring_simplify anomaly: bad goal after pre" + end. + +Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). + +Ltac Ring_nf Cst_tac lemma2 req rl f := + let on_rhs H := + match type of H with + | req _ ?rhs => clear H; f rhs + end in + Ring_norm_gen on_rhs Cst_tac lemma2 req rl. + + +Tactic Notation (at level 0) + "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := + let G := getGoal in ring_lookup Ring_simplify [lH] rl [G]. + +Tactic Notation (at level 0) + "ring_simplify" constr_list(rl) := + let G := getGoal in ring_lookup Ring_simplify [] rl [G]. + + +Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= + let G := getGoal 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 := getGoal 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. + + +(* + +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 new file mode 100644 index 00000000..5498911d --- /dev/null +++ b/contrib/setoid_ring/Ring_theory.v @@ -0,0 +1,601 @@ +(************************************************************************) +(* 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 1, no associativity). + +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)). + set (w:= x*pow_pos x j);unfold w at 2. + rewrite (mul_comm x (pow_pos x j));unfold w. + 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'] + }. + 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. + + 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;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. + + (** Usefull 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 O I add mul sub opp eq 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 new file mode 100644 index 00000000..8de7021e --- /dev/null +++ b/contrib/setoid_ring/ZArithRing.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* 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 + | _ => NotConstant + end. + +Ltac isZpow_coef t := + match t with + | Zpos ?p => isPcst p + | Z0 => true + | _ => 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 Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], + power_tac Zpower_theory [Zpow_tac]). + diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 new file mode 100644 index 00000000..8b2ce26b --- /dev/null +++ b/contrib/setoid_ring/newring.ml4 @@ -0,0 +1,1072 @@ +(************************************************************************) +(* 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 9603 2007-02-07 00:41:16Z barras $ i*) + +open Pp +open Util +open Names +open Term +open Closure +open Environ +open Libnames +open Tactics +open Rawterm +open Tacticals +open Tacexpr +open Pcoq +open Tactic +open Constr +open Setoid_replace +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(([],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 = + TacArg(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.evar_concl=mkProp; + Evd.evar_hyps=named_context_val env; + Evd.evar_body=Evd.Evar_empty; + Evd.evar_extra=None}; + 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"] + ] + +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 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_morphZ = zltac"inv_gen_phiZ" +let ltac_inv_morphN = zltac"inv_gen_phiN" +let coq_abstract = my_constant"Abstract" +let coq_comp = my_constant"Computational" +let coq_morph = my_constant"Morphism" + +(* 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 r = + lapp coq_mk_Setoid + [|r.rel_a; r.rel_aeq; + out_some r.rel_refl; out_some r.rel_sym; out_some r.rel_trans |] + +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 _} -> true + | _ -> 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 build_setoid_params r add mul opp req eqth = + match eqth with + Some th -> th + | None -> default_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" + + + +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 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 Nametab.global lc) + | None -> + (match opp, kind with + None, _ -> + let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in + TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) + | 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])) + | _ -> error"a tactic must be specified for an almost_ring") + +let make_hyp env c = + let t = (Typeops.typing env c).uj_type 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 Nametab.global 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 add_theory name rth eqth morphth cst_tac (pre,post) power sign = + 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 rk = reflect_coeff morphth in + let params = + exec_tactic env 5 (zltac "ring_lemmas") + (List.map carg[sth;ext;rth;pspec;sspec;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 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 + + +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) ] +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 + 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) l; + let k = match !kind with Some k -> k | None -> Abstract in + (k, !set, !cst_tac, !pre, !post, !power, !sign) + +VERNAC COMMAND EXTEND AddSetoidRing + | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> + [ let (k,set,cst,pre,post,power,sign) = process_ring_mods l in + add_theory id (ic t) set k cst (pre,post) power sign ] +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 + ([(dummy_loc,id_of_string"f"),None,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" tactic(f) "[" constr_list(lH) "]" constr_list(lr) + "[" constr(t) "]" ] -> + [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 default_field_equality r inv req = + let is_setoid = function + {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true + | _ -> false in + match default_relation_for_carrier ~filter:is_setoid r with + Leibniz _ -> + mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + | Relation rel -> + let is_endomorphism = function + { args=args } -> List.for_all + (function (var,Relation rel) -> + var=None && eq_constr req rel + | _ -> false) args in + let inv_m = + try default_morphism ~filter:is_endomorphism 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 = + 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 in + let (pow_tac, pspec) = interp_power env power in + let sspec = interp_sign env sign in + let inv_m = default_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;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 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 + 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 + | 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) + +VERNAC COMMAND EXTEND AddSetoidField +| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> + [ let (k,set,inj,cst_tac,pre,post,power,sign) = process_field_mods l in + add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign] +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 + ([(dummy_loc,id_of_string"f"),None,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" tactic(f) "[" constr_list(lH) "]" constr_list(l) + "[" constr(t) "]" ] -> + [ field_lookup (fst f) lH l t ] +END diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v new file mode 100644 index 00000000..46121ff1 --- /dev/null +++ b/contrib/subtac/FixSub.v @@ -0,0 +1,98 @@ +Require Import Wf. +Require Import Coq.subtac.Utils. + +Section Well_founded. + Variable A : Type. + Variable R : A -> A -> Prop. + Hypothesis Rwf : well_founded R. + + Section Acc. + + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := + F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) + (Acc_inv r (proj1_sig y) (proj2_sig y))). + + Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + End Acc. + + Section FixPoint. + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. + + Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) + + Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). + + Hypothesis + F_ext : + forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), + (forall y:{ y:A | R y x}, f y = g y) -> F_sub x f = F_sub x g. + + Lemma Fix_F_eq : + forall (x:A) (r:Acc R x), + F_sub x (fun (y:{y:A|R y x}) => Fix_F (`y) (Acc_inv r (proj1_sig y) (proj2_sig y))) = Fix_F x r. + Proof. + destruct r using Acc_inv_dep; auto. + Qed. + + Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s. + Proof. + intro x; induction (Rwf x); intros. + rewrite <- (Fix_F_eq x r); rewrite <- (Fix_F_eq x s); intros. + apply F_ext; auto. + intros. + rewrite (proof_irrelevance (Acc R x) r s) ; auto. + Qed. + + Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:{y:A|R y x}) => Fix (proj1_sig y)). + Proof. + intro x; unfold Fix in |- *. + rewrite <- (Fix_F_eq ). + apply F_ext; intros. + apply Fix_F_inv. + Qed. + + Lemma fix_sub_eq : + forall x : A, + Fix_sub P F_sub x = + let f_sub := F_sub in + f_sub x (fun {y : A | R y x}=> Fix (`y)). + exact Fix_eq. + Qed. + + End FixPoint. + +End Well_founded. + +Extraction Inline Fix_F_sub Fix_sub. + +Require Import Wf_nat. +Require Import Lt. + +Section Well_founded_measure. +Variable A : Type. +Variable f : A -> nat. +Definition R := fun x y => f x < f y. + +Section FixPoint. + +Variable P : A -> Type. + +Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x. + +Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (f x)) {struct r} : P x := + F_sub x (fun y: { y : A | f y < f x} => Fix_measure_F_sub (proj1_sig y) + (Acc_inv r (f (proj1_sig y)) (proj2_sig y))). + +Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)). + +End FixPoint. + +End Well_founded_measure. + +Extraction Inline Fix_measure_F_sub Fix_measure_sub. diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v new file mode 100644 index 00000000..1a12ac82 --- /dev/null +++ b/contrib/subtac/FunctionalExtensionality.v @@ -0,0 +1,25 @@ +Axiom fun_extensionality : forall A B (f g : A -> B), + (forall x, f x = g x) -> f = g. + +Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), forall (f g : forall x : A, B x), + (forall x, f x = g x) -> f = g. + +Hint Resolve fun_extensionality fun_extensionality_dep : subtac. + +Require Import Coq.subtac.Utils. +Require Import Coq.subtac.FixSub. + +Lemma fix_sub_eq_ext : + forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R) + (P : A -> Set) + (F_sub : forall x : A, (forall {y : A | R y x}, P (`y)) -> P x), + forall x : A, + Fix_sub A R Rwf P F_sub x = + F_sub x (fun {y : A | R y x}=> Fix A R Rwf P F_sub (`y)). +Proof. + intros ; apply Fix_eq ; auto. + intros. + assert(f = g). + apply (fun_extensionality_dep _ _ _ _ H). + rewrite H0 ; auto. +Qed. diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v new file mode 100644 index 00000000..9912cd24 --- /dev/null +++ b/contrib/subtac/Subtac.v @@ -0,0 +1,2 @@ +Require Export Coq.subtac.Utils. +Require Export Coq.subtac.FixSub.
\ No newline at end of file diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v new file mode 100644 index 00000000..4a2208ce --- /dev/null +++ b/contrib/subtac/Utils.v @@ -0,0 +1,75 @@ +Set Implicit Arguments. + +Notation "'fun' { x : A | P } => Q" := + (fun x:{x:A|P} => Q) + (at level 200, x ident, right associativity). + +Notation "( x & ? )" := (@exist _ _ x _) : core_scope. + +Notation " ! " := (False_rect _ _). + +Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. +intros. +induction t. +exact x. +Defined. + +Lemma ex_pi2 : forall (A : Prop) (P : A -> Prop) (t : ex P), + P (ex_pi1 t). +intros A P. +dependent inversion t. +simpl. +exact p. +Defined. + + +Notation "` t" := (proj1_sig t) (at level 100) : core_scope. +Notation "'forall' { x : A | P } , Q" := + (forall x:{x:A|P}, Q) + (at level 200, x ident, right associativity). + +Lemma subset_simpl : forall (A : Set) (P : A -> Prop) + (t : sig P), P (` t). +Proof. +intros. +induction t. + simpl ; auto. +Qed. + +Ltac destruct_one_pair := + match goal with + | [H : (ex _) |- _] => destruct H + | [H : (ex2 _) |- _] => destruct H + | [H : (sig _) |- _] => destruct H + | [H : (_ /\ _) |- _] => destruct H +end. + +Ltac destruct_exists := repeat (destruct_one_pair) . + +Ltac subtac_simpl := simpl ; intros ; destruct_exists ; simpl in * ; try subst ; auto with arith. + +(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *) +Ltac destruct_call f := + match goal with + | H : ?T |- _ => + match T with + context [f ?x ?y ?z] => destruct (f x y z) + | context [f ?x ?y] => destruct (f x y) + | context [f ?x] => destruct (f x) + end + | |- ?T => + match T with + context [f ?x ?y ?z] => let n := fresh "H" in set (n:=f x y z); destruct n + | context [f ?x ?y] => let n := fresh "H" in set (n:=f x y); destruct n + | context [f ?x] => let n := fresh "H" in set (n:=f x); destruct n + end + end. + +Extraction Inline proj1_sig. +Extract Inductive unit => "unit" [ "()" ]. +Extract Inductive bool => "bool" [ "true" "false" ]. +Extract Inductive sumbool => "bool" [ "true" "false" ]. +Extract Inductive prod => "pair" [ "" ]. +Extract Inductive sigT => "pair" [ "" ]. + +Require Export ProofIrrelevance. diff --git a/contrib/subtac/context.ml b/contrib/subtac/context.ml new file mode 100644 index 00000000..236b0ea5 --- /dev/null +++ b/contrib/subtac/context.ml @@ -0,0 +1,35 @@ +open Term +open Names + +type t = rel_declaration list (* name, optional coq interp, algorithmic type *) + +let assoc n t = + let _, term, typ = List.find (fun (x, _, _) -> x = n) t in + term, typ + +let assoc_and_index x l = + let rec aux i = function + (y, term, typ) :: tl -> if x = y then i, term, typ else aux (succ i) tl + | [] -> raise Not_found + in aux 0 l + +let id_of_name = function + Name id -> id + | Anonymous -> raise (Invalid_argument "id_of_name") +(* + +let subst_ctx ctx c = + let rec aux ((ctx, n, c) as acc) = function + (name, None, typ) :: tl -> + aux (((id_of_name name, None, rel_to_vars ctx typ) :: ctx), + pred n, c) tl + | (name, Some term, typ) :: tl -> + let t' = Term.substnl [term] n c in + aux (ctx, n, t') tl + | [] -> acc + in + let (x, _, z) = aux ([], pred (List.length ctx), c) (List.rev ctx) in + (x, rel_to_vars x z) +*) + +let subst_env env c = (env, c) diff --git a/contrib/subtac/context.mli b/contrib/subtac/context.mli new file mode 100644 index 00000000..671d6f36 --- /dev/null +++ b/contrib/subtac/context.mli @@ -0,0 +1,5 @@ +type t = Term.rel_declaration list +val assoc : 'a -> ('a * 'b * 'c) list -> 'b * 'c +val assoc_and_index : 'a -> ('a * 'b * 'c) list -> int * 'b * 'c +val id_of_name : Names.name -> Names.identifier +val subst_env : 'a -> 'b -> 'a * 'b diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml new file mode 100644 index 00000000..1844fea5 --- /dev/null +++ b/contrib/subtac/eterm.ml @@ -0,0 +1,178 @@ +(** + - 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 Names +open Evd +open List +open Pp +open Util + +let reverse_array arr = + Array.of_list (List.rev (Array.to_list arr)) + +let trace s = + if !Options.debug then (msgnl s; msgerr s) + else () + +(** Utilities to find indices in lists *) +let list_index x l = + let rec aux i = function + k :: tl -> if k = x then i else aux (succ i) tl + | [] -> raise Not_found + in aux 0 l + +let list_assoc_index x l = + let rec aux i = function + (k, _, v) :: tl -> if k = x then i else aux (succ i) tl + | [] -> raise Not_found + in aux 0 l + + +(** 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 evar_info id = + let rec aux i = function + (k, x) :: tl -> + if k = id then x else aux (succ i) tl + | [] -> raise Not_found + in aux 0 evs + in + let rec substrec depth c = match kind_of_term c with + | Evar (k, args) -> + let (id, idstr), hyps, _, _ = + try evar_info k + with Not_found -> + anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") + in + seen := Intset.add id !seen; +(* (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ *) +(* int (List.length hyps) ++ str " hypotheses"); with _ -> () ); *) + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let rec aux hyps args acc = + match hyps, args with + ((_, None, _) :: tlh), (c :: tla) -> + aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc) + | ((_, Some _, _) :: tlh), (_ :: tla) -> + aux tlh tla acc + | [], [] -> acc + | _, _ -> acc (*failwith "subst_evars: invalid argument"*) + in aux hyps (Array.to_list args) [] + in + mkApp (mkVar idstr, Array.of_list args) + | _ -> map_constr_with_binders succ substrec depth c + in + let t' = substrec 0 t in + t', !seen + + +(** 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 = + let idx = list_index id acc in + idx + 1 + 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. +*) +let etype_of_evar evs ev hyps = + let rec aux acc n = function + (id, copt, t) :: tl -> + let t', s = subst_evar_constr evs n t in + let t'' = subst_vars acc 0 t' in + let copt', s = + match copt with + Some c -> + let c', s' = subst_evar_constr evs n c in + Some c', Intset.union s s' + | None -> None, s + in + let copt' = option_map (subst_vars acc 0) copt' in + let rest, s' = aux (id :: acc) (succ n) tl in + mkNamedProd_or_LetIn (id, copt', t'') rest, Intset.union s' s + | [] -> + let t', s = subst_evar_constr evs n ev.evar_concl in + subst_vars acc 0 t', s + in aux [] 0 (rev hyps) + + +open Tacticals + +let rec take n l = + if n = 0 then [] else List.hd l :: take (pred n) (List.tl l) + +let trunc_named_context n ctx = + let len = List.length ctx in + take (len - n) ctx + +let eterm_obligations name nclen evm t tycon = + (* 'Serialize' the evars, we assume that the types of the existentials + refer to previous existentials in the list only *) + let evl = List.rev (to_list evm) 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 = Environ.named_context_of_val ev.evar_hyps in + let hyps = trunc_named_context nclen hyps in + let evtyp, deps = etype_of_evar l ev hyps in + let y' = (id, ((n, nstr), hyps, evtyp, deps)) in + y' :: l) + evn [] + in + let t', _ = (* Substitute evar refs in the term by variables *) + subst_evar_constr evts 0 t + in + let evars = + List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts + in +(* (try *) +(* trace (str "Term given to eterm" ++ spc () ++ *) +(* Termops.print_constr_env (Global.env ()) t); *) +(* trace (str "Term constructed in eterm" ++ spc () ++ *) +(* Termops.print_constr_env (Global.env ()) t'); *) +(* ignore(iter *) +(* (fun (name, typ, deps) -> *) +(* trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ *) +(* Termops.print_constr_env (Global.env ()) typ)) *) +(* evars); *) +(* with _ -> ()); *) + Array.of_list (List.rev evars), t' + +let mkMetas n = + let rec aux i acc = + if i > 0 then aux (pred i) (Evarutil.mk_new_meta () :: acc) + else acc + in aux n [] + +(* let eterm evm t (tycon : types option) = *) +(* let t, tycon, evs = eterm_term evm t tycon in *) +(* match tycon with *) +(* Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *) +(* | None -> Tactics.apply_term t (mkMetas (List.length evs)) *) + +(* open Tacmach *) + +let etermtac (evm, t) = assert(false) (*eterm evm t None *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli new file mode 100644 index 00000000..3a571ee1 --- /dev/null +++ b/contrib/subtac/eterm.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* 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 9326 2006-10-31 12:57:26Z msozeau $ i*) + +open Tacmach +open Term +open Evd +open Names +open Util + +val mkMetas : int -> constr list + +(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) + +val eterm_obligations : identifier -> int -> evar_map -> constr -> types option -> + (identifier * types * Intset.t) array * constr (* Obl. name, type as product 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 new file mode 100644 index 00000000..d9dd42cd --- /dev/null +++ b/contrib/subtac/g_eterm.ml4 @@ -0,0 +1,27 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..e31326e9 --- /dev/null +++ b/contrib/subtac/g_subtac.ml4 @@ -0,0 +1,121 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(* + Syntax for the subtac terms and types. + Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) + +(* $Id: g_subtac.ml4 9588 2007-02-02 16:17:13Z herbelin $ *) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Options +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 SubtacGram +open Util +open Pcoq + +let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +GEXTEND Gram + GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder subtac_nameopt; + + subtac_gallina_loc: + [ [ g = Vernac.gallina -> 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], t, c)]) in + LocalRawAssum ([id], typ) + ] ]; + + Constr.binder: + [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> + ([id],mkAppC (sigref, [mkLambdaC ([id], c, p)])) + | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" -> + ([id],c) + | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" -> + (id::lid,c) + ] ]; + + END + + +type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type + +let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype), + (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr ) gallina_loc_argtype), + (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) = + Genarg.create_arg "subtac_gallina_loc" + +type 'a nameopt_argtype = (identifier option, 'a, '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_Obligations +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ] +| [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ] +| [ "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 +| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.interp 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 diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml new file mode 100644 index 00000000..5e46bead --- /dev/null +++ b/contrib/subtac/subtac.ml @@ -0,0 +1,267 @@ +(************************************************************************) +(* 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 9563 2007-01-31 09:37:18Z 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 Context +open Eterm + +let require_library dirpath = + let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in + Library.require_library [qualid] None +(* +let subtac_one_fixpoint env isevars (f, decl) = + let ((id, n, bl, typ, body), decl) = + Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl) + in + let _ = + try trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++ + Ppconstr.pr_constr_expr body) + with _ -> () + in ((id, n, bl, typ, body), decl) +*) + +let subtac_fixpoint isevars l = + (* TODO: Copy command.build_recursive *) + () +(* +let save 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 + Pfedit.delete_current_proof (); + hook l r; + definition_message id + +let save_named opacity = + let id,(const,persistence,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + save id const persistence hook + +let check_anonymity id save_ident = + if atompart_of_id id <> "Unnamed_thm" then + error "This command can only be used for unnamed theorem" +(* + message("Overriding name "^(string_of_id id)^" and using "^save_ident) +*) + +let save_anonymous opacity save_ident = + let id,(const,persistence,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + save save_ident const persistence hook + +let save_anonymous_with_strength kind opacity save_ident = + let id,(const,_,hook) = Pfedit.cook_proof () in + let const = { const with const_entry_opaque = opacity } in + check_anonymity id save_ident; + (* we consider that non opaque behaves as local for discharge *) + save save_ident const (Global, Proof kind) hook + +let subtac_end_proof = function + | Admitted -> admit () + | Proved (is_opaque,idopt) -> + if_verbose show_script (); + match idopt with + | None -> save_named is_opaque + | Some ((_,id),None) -> save_anonymous is_opaque id + | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id + + *) + +open Pp +open Ppconstr +open Decl_kinds +open Tacinterp +open Tacexpr + +let start_proof_com env isevars sopt kind (bl,t) hook = + let id = match sopt with + | Some 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 + errorlabstrm "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 = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None + in + let _ = Typeops.infer_type env c in + Command.start_proof id kind c hook + +let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + +let subtac_utils_path = + make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"]) +let utils_tac s = + lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s)) + +let utils_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args)) + +let start_proof_and_print env isevars idopt k t hook = + start_proof_com env isevars idopt k t hook; + print_subgoals () + (*if !pcoq <> None then (out_some !pcoq).start_proof ()*) + +let _ = Subtac_obligations.set_default_tactic + (Tacinterp.eval_tactic (utils_call "subtac_simpl" [])) + + +let subtac (loc, command) = + check_required_library ["Coq";"Init";"Datatypes"]; + check_required_library ["Coq";"Init";"Specif"]; + (* check_required_library ["Coq";"Logic";"JMeq"]; *) + require_library "Coq.subtac.FixSub"; + require_library "Coq.subtac.Utils"; + let env = Global.env () in + let isevars = ref (create_evar_defs Evd.empty) in + try + match command with + VernacDefinition (defkind, (locid, id), expr, hook) -> + (match expr with + ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None +(* let evm, c, ctyp = in *) +(* trace (str "Starting proof"); *) +(* Command.start_proof id goal_kind c hook; *) +(* trace (str "Started proof"); *) + + | DefineBody (bl, _, c, tycon) -> + Subtac_pretyping.subtac_proof env isevars id bl c tycon + (* let tac = Eterm.etermtac (evm, c) in *) + (* trace (str "Starting proof"); *) + (* Command.start_proof id goal_kind ctyp hook; *) + (* trace (str "Started proof"); *) + (* Pfedit.by tac) *)) + | VernacFixpoint (l, b) -> + let _ = trace (str "Building fixpoint") in + ignore(Subtac_command.build_recursive l b) + + | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) -> + 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"); + start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook + + + + (*| 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 + + | 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, 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'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); + raise e) + + | e -> + msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); + raise e + + diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli new file mode 100644 index 00000000..25922782 --- /dev/null +++ b/contrib/subtac/subtac.mli @@ -0,0 +1,3 @@ +val require_library : string -> unit +val subtac_fixpoint : 'a -> 'b -> unit +val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml new file mode 100644 index 00000000..fbe1ac37 --- /dev/null +++ b/contrib/subtac/subtac_cases.ml @@ -0,0 +1,1925 @@ +(************************************************************************) +(* 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: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *) + +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 errors *) + +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | WrongPredicateArity of constr * constr * constr + | NeedsInversion of constr * constr + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * pattern_matching_error + +let raise_pattern_matching_error (loc,ctx,te) = + Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te)) + +let error_bad_pattern_loc loc cstr ind = + raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind)) + +let error_bad_constructor_loc loc cstr ind = + raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind)) + +let error_wrong_numarg_constructor_loc loc env c n = + raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n)) + +let error_wrong_numarg_inductive_loc loc env c n = + raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n)) + +let error_wrong_predicate_arity_loc loc env c n1 n2 = + raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2)) + +let error_needs_inversion env x t = + raise (PatternMatchingError (env, NeedsInversion (x,t))) + +module type S = sig + val compile_cases : + loc -> + (type_constraint -> env -> rawconstr -> unsafe_judgment) * + Evd.evar_defs ref -> + type_constraint -> + env -> rawconstr option * tomatch_tuple * cases_clauses -> + unsafe_judgment +end + +(************************************************************************) +(* 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; + tag : pattern_source } + +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; + 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 } + +(**********************************************************************) +(* Dealing with regular and default patterns *) +let is_regular eqn = eqn.tag = RegularPat + +let lower_pattern_status = function + | RegularPat -> DefaultPat 0 + | DefaultPat n -> DefaultPat (n+1) + +let pattern_status pats = + if array_exists ((=) RegularPat) pats then RegularPat + else + let min = + Array.fold_right + (fun pat n -> match pat with + | DefaultPat i when i<n -> i + | _ -> n) + pats 0 in + DefaultPat min + +(**********************************************************************) +(* 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.tag, 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 +(* trace (str "push_rels_eqn: " ++ my_print_rel_context eqn.rhs.rhs_env sign ++ str "end"); *) +(* str " branch is " ++ my_print_constr (fst eqn.rhs.c_orig) (snd eqn.rhs.c_orig)); *) +(* let rhs = eqn.rhs in *) +(* let l, c, s, e = *) +(* List.fold_right *) +(* (fun (na, c, t) (itlift, it, sign, env) -> *) +(* (try trace (str "Pushing decl: " ++ pr_rel_decl env (na, c, t) ++ *) +(* str " lift is " ++ int itlift); *) +(* with _ -> trace (str "error in push_rels_eqn")); *) +(* let env' = push_rel (na, c, t) env in *) +(* match sign with *) +(* [] -> (itlift, lift 1 it, sign, env') *) +(* | (na', c, t) :: sign' -> *) +(* if na' = na then *) +(* (pred itlift, it, sign', env') *) +(* else ( *) +(* trace (str "skipping it"); *) +(* (itlift, liftn 1 itlift it, sign, env'))) *) +(* sign (rhs.rhs_lift, rhs.c_it, eqn.rhs.rhs_sign, eqn.rhs.rhs_env) *) +(* 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_betaevar empty_env (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 (applist (pred, realargs)) in + if dep then + (pred, whd_beta (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 + let rest = {rest with tag = lower_pattern_status rest.tag } 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 tag, 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 + tag, 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 tags = Array.map (fun (t,_,_) -> t) brs in + 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 RegularStyle tags in + let case = mkCase (ci,nf_betaiota pred,current,brvals) in + let inst = List.map mkRel deps in + pattern_status tags, + { 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 tag, j = compile pb in + (tag, 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 patstat,j = compile pb in + patstat, + { 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 patstat,j = compile pb in + patstat, + 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; + tag = RegularPat; + alias_stack = []; + eqn_loc = loc; + used = ref false; + rhs = rhs } + in List.map build_eqn eqns + +(************************************************************************) +(* preparing the elimination predicate if any *) + +let build_expected_arity env isevars isdep tomatchl = + let cook n = function + | _,IsInd (_,IndType(indf,_)) -> + let indf' = lift_inductive_family n indf in + Some (build_dependent_inductive env indf', fst (get_arity env indf')) + | _,NotInd _ -> None + in + let rec buildrec n env = function + | [] -> new_Type () + | tm::ltm -> + match cook n tm with + | None -> buildrec n env ltm + | Some (ty1,aritysign) -> + let rec follow n env = function + | d::sign -> + mkProd_or_LetIn_name env + (follow (n+1) (push_rel d env) sign) d + | [] -> + if isdep then + mkProd (Anonymous, ty1, + buildrec (n+1) + (push_rel_assum (Anonymous, ty1) env) + ltm) + else buildrec n env ltm + in follow n env (List.rev aritysign) + in buildrec 0 env tomatchl + +let extract_predicate_conclusion isdep tomatchl pred = + let cook = function + | _,IsInd (_,IndType(_,args)) -> Some (List.length args) + | _,NotInd _ -> None in + let rec decomp_lam_force n l p = + if n=0 then (l,p) else + match kind_of_term p with + | Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c + | _ -> (* eta-expansion *) + let na = Name (id_of_string "x") in + decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in + let rec buildrec allnames p = function + | [] -> (List.rev allnames,p) + | tm::ltm -> + match cook tm with + | None -> + let p = + (* adjust to a sign containing the NotInd's *) + if isdep then lift 1 p else p in + let names = if isdep then [Anonymous] else [] in + buildrec (names::allnames) p ltm + | Some n -> + let n = if isdep then n+1 else n in + let names,p = decomp_lam_force n [] p in + buildrec (names::allnames) p ltm + in buildrec [] pred tomatchl + +let set_arity_signature dep n arsign tomatchl pred x = + (* avoid is not exhaustive ! *) + let rec decomp_lam_force n avoid l p = + if n = 0 then (List.rev l,p,avoid) else + match p with + | RLambda (_,(Name id as na),_,c) -> + decomp_lam_force (n-1) (id::avoid) (na::l) c + | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c + | _ -> + let x = next_ident_away (id_of_string "x") avoid in + decomp_lam_force (n-1) (x::avoid) (Name x :: l) + (* eta-expansion *) + (let a = RVar (dummy_loc,x) in + match p with + | RApp (loc,p,l) -> RApp (loc,p,l@[a]) + | _ -> (RApp (dummy_loc,p,[a]))) in + let rec decomp_block avoid p = function + | ([], _) -> x := Some p + | ((_,IsInd (_,IndType(indf,realargs)))::l),(y::l') -> + let (ind,params) = dest_ind_family indf in + let (nal,p,avoid') = decomp_lam_force (List.length realargs) avoid [] p + in + let na,p,avoid' = + if dep then decomp_lam_force 1 avoid' [] p else [Anonymous],p,avoid' + in + y := + (List.hd na, + if List.for_all ((=) Anonymous) nal then + None + else + Some (dummy_loc, ind, (List.map (fun _ -> Anonymous) params)@nal)); + decomp_block avoid' p (l,l') + | (_::l),(y::l') -> + y := (Anonymous,None); + decomp_block avoid p (l,l') + | _ -> anomaly "set_arity_signature" + in + decomp_block [] pred (tomatchl,arsign) + +let prepare_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 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 list_mapi f l = + let rec aux n = function + [] -> [] + | hd :: tl -> f n hd :: aux (succ n) tl + in aux 0 l + +let constr_of_pat env isevars ty pat idents = + let rec typ env ty pat idents = + trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++ + print_env env ++ str" should have type: " ++ my_print_constr env ty); + match pat with + | PatVar (l,name) -> + let name, idents' = match name with + Name n -> name, idents + | Anonymous -> + let n' = next_ident_away_from (id_of_string "wildcard") idents in + Name n', n' :: idents + in +(* trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); *) + PatVar (l, name), [name, None, ty], mkRel 1, 1, idents' + | PatCstr (l,((_, i) as cstr),args,alias) -> + let _ind = inductive_of_constructor cstr in + let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) ty in + let ind, params = dest_ind_family indf in + 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 idents' = idents in + let patargs, args, sign, env, n, m, idents' = + List.fold_right2 + (fun (na, c, t) ua (patargs, args, sign, env, n, m, idents) -> + let pat', sign', arg', n', idents' = typ env (lift (n - m) t) ua idents 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, idents')) + ci.cs_args (List.rev args) ([], [], [], env, 0, 0, idents') + 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 +(* trace (str "New pattern: " ++ Printer.pr_cases_pattern pat'); *) +(* let alname = if alias <> Anonymous then alias else Name (id_of_string "anon") in *) +(* let al = alname, Some (mkRel 1), lift 1 ty in *) + if alias <> Anonymous then + pat', (alias, Some app, ty) :: sign, lift 1 app, n + 1, idents' + else pat', sign, app, n, idents' + in + let pat', sign, y, z, idents = typ env ty pat idents in + let c = it_mkProd_or_LetIn y sign in + trace (str "Constr_of_pat gives: " ++ my_print_constr env c); + pat', (sign, y), idents + +let mk_refl typ a = mkApp (Lazy.force eq_refl, [| typ; a |]) + +let vars_of_ctx = + List.rev_map (fun (na, _, t) -> + match na with + Anonymous -> raise (Invalid_argument "vars_of_ctx") + | Name n -> RVar (dummy_loc, n)) + +(*let build_ineqs eqns pats = + List.fold_left + (fun (sign, c) eqn -> + let acc = fold_left3 + (fun acc prevpat (ppat_sign, ppat_c, ppat_ty) (pat, pat_c) -> + match acc with + None -> None + | Some (sign,len, c) -> + if is_included pat prevpat then + let lens = List.length ppat_sign in + let acc = + (lift_rels lens ppat_sign @ sign, + lens + len, + mkApp (Lazy.force eq_ind, + [| ppat_ty ; ppat_c ; + lift (lens + len) pat_c |]) :: c) + in Some acc + else None) + (sign, c) eqn.patterns eqn.c_patterns pats + in match acc with + None -> (sign, c) + | Some (sign, len, c) -> + it_mkProd_or_LetIn c sign + + ) + ([], []) eqns*) + +let constrs_of_pats typing_fun tycon env isevars eqns tomatchs = + let i = ref 0 in + List.fold_left + (fun (branches, eqns) eqn -> + let _, newpatterns, pats = + List.fold_right2 (fun pat (_, ty) (idents, newpatterns, pats) -> + let x, y, z = constr_of_pat env isevars (type_of_tomatch ty) pat idents in + (z, x :: newpatterns, y :: pats)) + eqn.patterns tomatchs ([], [], []) + in + let rhs_rels, signlen = + List.fold_left (fun (renv, n) (sign,_) -> + ((lift_rel_context n sign) @ renv, List.length sign + n)) + ([], 0) pats in + let eqs, _, _ = List.fold_left2 + (fun (eqs, n, slen) (sign, c) (tm, ty) -> + let len = n + signlen in (* Number of already defined equations + signature *) + let csignlen = List.length sign in + let slen' = slen - csignlen in (* Lift to get pattern variables signature *) + let c = liftn (signlen - slen) signlen c in (* Lift to jump over previous ind signatures for pattern variables outside sign + in c (e.g. type arguments of constructors instanciated by variables ) *) + let cstr = lift (slen' + n) c in +(* trace (str "lift " ++ my_print_constr (push_rels sign env) c ++ *) +(* str " by " ++ int ++ str " to get " ++ *) +(* my_print_constr (push_rels sign env) cstr); *) + let app = + mkApp (Lazy.force eq_ind, + [| lift len (type_of_tomatch ty); cstr; lift len tm |]) + in app :: eqs, succ n, slen') + ([], 0, signlen) pats tomatchs + in + let eqs_rels = List.map (fun eq -> Name (id_of_string "H"), None, eq) eqs in +(* let ineqs = build_ineqs eqns newpatterns in *) + let rhs_rels' = eqs_rels @ rhs_rels in + let rhs_env = push_rels rhs_rels' env in +(* (try trace (str "branch env: " ++ print_env rhs_env) *) +(* with _ -> trace (str "error in print branch env")); *) + let tycon = lift_tycon (List.length eqs + signlen) tycon in + + let j = typing_fun tycon rhs_env eqn.rhs.it in +(* (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *) +(* str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *) +(* with _ -> *) +(* trace (str "Error in typed branch pretty printing")); *) + 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 +(* (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *) +(* with _ -> trace (str "Error in branch decl pp")); *) + 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 = *) +(* List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *) +(* in *) +(* (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *) +(* with _ -> trace (str "Error in new branch pp")); *) + incr i; + let rhs = { eqn.rhs with it = branch } in + (branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns)) + ([], []) eqns + + +(* liftn_rel_declaration *) + + +(* 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 prepare_predicate_from_tycon loc typing_fun isevars env tomatchs arsign tycon = + (* We extract the signature of the arity *) +(* List.iter *) +(* (fun arsign -> *) +(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *) +(* arsign; *) +(* let env = List.fold_right push_rels arsign env 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 pred = out_some (valcon_of_tycon tycon) in + let predcclj, pred, neqs = + let _, _, eqs = + List.fold_left2 + (fun (neqs, slift, eqs) ctx (tm,ty) -> + let len = List.length ctx in + let _name, _, _typ' = List.hd ctx in (* FixMe: Ignoring dependent inductives *) + let eq = mkApp (Lazy.force eq_ind, + [| lift (neqs + nar) (type_of_tomatch ty); + mkRel (neqs + slift); + lift (neqs + nar) tm|]) + in + (succ neqs, slift - len, (Anonymous, None, eq) :: eqs)) + (0, nar, []) (List.rev arsign) tomatchs + in + let len = List.length eqs in + it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len + in + let predccl = nf_isevar !isevars predcclj in +(* let env' = List.fold_right push_rel_context arsign env in *) +(* trace (str " Env:" ++ my_print_env env' ++ str" Predicate: " ++ my_print_constr env' predccl); *) + build_initial_predicate true allnames predccl, pred + +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 env = List.fold_right push_rels arsign env in + let allnames = List.rev (List.map (List.map pi1) arsign) in + let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in +(* let _ = *) +(* option_map (fun tycon -> *) +(* isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val *) +(* (lift_tycon_type (List.length arsign) tycon)) *) +(* tycon *) +(* in *) + let predccl = (j_nf_isevar !isevars predcclj).uj_val in + Some (build_initial_predicate true allnames predccl) + +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 1 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 + +(**************************************************************************) +(* Main entry of the matching compilation *) + +let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)= + let tycon0 = tycon 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 tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in + let tomatchs_len = List.length tomatchs_lets in + let tycon = lift_tycon tomatchs_len tycon in + let env = push_rel_context tomatchs_lets env in + match predopt with + None -> + let lets, matx = constrs_of_pats typing_fun tycon env isevars matx tomatchs in + let matx = List.rev matx in + let len = List.length lets in + let sign = + let arsign = extract_arity_signature env tomatchs (List.map snd tomatchl) in + List.map (lift_rel_context len) arsign + 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 tycon = lift_tycon len tycon in + let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in + let args = List.map (fun (tm,ty) -> mk_refl (type_of_tomatch ty) tm) tomatchs in + + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let pred, opred = prepare_predicate_from_tycon loc typing_fun isevars env tomatchs sign tycon 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; + typing_function = typing_fun } in + + let _, j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let ty = out_some (valcon_of_tycon tycon0) in + 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 = ty; } + in + inh_conv_coerce_to_tycon loc env isevars j tycon0 + + | Some rtntyp -> + (* 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 rtntyp 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; + typing_function = typing_fun } in + + let _, j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let j = { j with uj_val = it_mkLambda_or_LetIn j.uj_val tomatchs_lets } in + 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 new file mode 100644 index 00000000..9e902126 --- /dev/null +++ b/contrib/subtac/subtac_cases.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* 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: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*) + +(*i*) +open Util +open Names +open Term +open Evd +open Environ +open Inductiveops +open Rawterm +open Evarutil +(*i*) + +type pattern_matching_error = + | BadPattern of constructor * constr + | BadConstructor of constructor * inductive + | WrongNumargConstructor of constructor * int + | WrongNumargInductive of inductive * int + | WrongPredicateArity of constr * constr * constr + | NeedsInversion of constr * constr + | UnusedClause of cases_pattern list + | NonExhaustive of cases_pattern list + | CannotInferPredicate of (constr * types) array + +exception PatternMatchingError of env * pattern_matching_error + +val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a + +val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a + +(*s Compilation of pattern-matching. *) + +module type S = sig + val compile_cases : + loc -> + (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref -> + type_constraint -> + env -> rawconstr option * tomatch_tuple * cases_clauses -> + unsafe_judgment +end + +module Cases_F(C : Coercion.S) : S diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml new file mode 100644 index 00000000..3613ec4f --- /dev/null +++ b/contrib/subtac/subtac_coercion.ml @@ -0,0 +1,527 @@ +(************************************************************************) +(* 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 9563 2007-01-31 09:37:18Z 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 Context +open Eterm +open Pp + +let pair_of_array a = (a.(0), a.(1)) +let make_name s = Name (id_of_string s) + +module Coercion = struct + + exception NoSubtacCoercion + + 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 + + + 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 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 +(* (try debug 1 (str "Coerce called for " ++ (my_print_constr env x) ++ *) +(* str " and "++ my_print_constr env y ++ *) +(* str " with evars: " ++ spc () ++ *) +(* my_print_evardefs !isevars); *) +(* with _ -> ()); *) + let rec coerce_unify env x y = +(* (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y) *) +(* with _ -> ()); *) + try + isevars := the_conv_x_leq env x y !isevars; +(* (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ *) +(* str " and "++ my_print_constr env y); *) +(* with _ -> ()); *) + None + with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y) + and coerce' env x y : (Term.constr -> Term.constr) option = + let subco () = subset_coerce env isevars x y in +(* (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ *) +(* str " to "++ my_print_constr env y); *) +(* with _ -> ()); *) + 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 + let c2 = coerce_unify env' b b' in + (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, + [| app_opt c1 (mkRel 1) |]))))) + + | App (c, l), App (c', l') -> + (match kind_of_term c, kind_of_term c' with + Ind i, Ind i' -> (* Sigma types *) + let len = Array.length l in + let existS = Lazy.force existS in + let prod = Lazy.force prod in + 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 len = 1 && len = Array.length l' && i = i' then *) +(* let argx, argy = l.(0), l'.(0) in *) +(* let indtyp = Inductiveops.type_of_inductive env i in *) +(* let argname, argtype, _ = destProd indtyp in *) +(* let eq = *) +(* mkApp (Lazy.force eqind, [| argtype; argx; argy |]) *) +(* in *) +(* let pred = mkLambda (argname, argtype, *) +(* mkApp (mkInd i, [| mkRel 1 |])) *) +(* in *) +(* let evar = make_existential dummy_loc env isevars eq in *) +(* Some (fun x -> *) +(* mkApp (Lazy.force eqrec, *) +(* [| argtype; argx; pred; x; argy; evar |])) *) +(* else *)subco () + | x, y when x = y -> + let lam_type = Typing.type_of env (evars_of !isevars) c in + let rec coerce typ i co = + if i < Array.length l then + let hdx = l.(i) and hdy = l'.(i) in + let (n, eqT, restT) = destProd typ in + let pred = mkLambda (n, eqT, mkApp (lift 1 c, [| mkRel 1 |])) in + let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in + let evar = make_existential dummy_loc env isevars eq in + let eq_app x = mkApp (Lazy.force eq_rect, + [| eqT; hdx; pred; x; hdy; evar|]) + in + coerce (subst1 hdy restT) (succ i) (fun x -> eq_app (co x)) + else co + in + if Array.length l = Array.length l' then ( + trace (str"Inserting coercion at application"); + Some (coerce lam_type 0 (fun x -> x)) + ) else subco () + | _ -> subco ()) + | _, _ -> subco () + + and subset_coerce env isevars x y = + match disc_subset x with + Some (u, p) -> + (* trace (str "Inserting projection "); *) + 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 dummy_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, t + + (* Taken from pretyping/coercion.ml *) + + (* Typing operations dealing with coercions *) + + let class_of1 env sigma t = class_of env sigma (nf_evar sigma t) + + (* 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 i1 = inductive_class_of ind1 in + let i2 = inductive_class_of ind2 in + let p = lookup_pattern_path_between (i1,i2) in + apply_pattern_coercion loc pat p + + (* appliquer le chemin de coercions p à hj *) + + let apply_coercion env 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 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_arrow isevars ev in + (isevars',{ uj_val = j.uj_val; uj_type = t }) + | _ -> + (try + let t,i1 = class_of1 env (evars_of isevars) j.uj_type in + let p = lookup_path_to_fun_from i1 in + (isevars,apply_coercion env 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,i1 = class_of1 env (evars_of isevars) j.uj_type in + let p = lookup_path_to_sort_from i1 in + let j1 = apply_coercion env 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_fail env isevars c1 v t = + let v', t' = + try + let t1,i1 = class_of1 env (evars_of isevars) c1 in + let t2,i2 = class_of1 env (evars_of isevars) t in + let p = lookup_path_between (i2,i1) in + match v with + Some v -> + let j = apply_coercion env 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 isevars, v', t') + with Reduction.NotConvertible -> raise NoCoercion + + let rec inh_conv_coerce_to_fail loc env isevars v t c1 = +(* (try *) +(* debug 1 (str "inh_conv_coerce_to_fail called for " ++ *) +(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *) +(* Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ *) +(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) + try (the_conv_x_leq env t c1 isevars, v, t) + with Reduction.NotConvertible -> + (try + inh_coerce_to_fail env isevars c1 v t + with NoCoercion -> + (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t), + kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with + | Prod (_,t1,t2), Prod (name,u1,u2) -> + let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in + let (evd',b) = + match v' with + Some v' -> + (match kind_of_term v' with + | Lambda (x,v1,v2) -> + (try the_conv_x env v1 u1 isevars, Some (x, v1, v2) (* leq v1 u1? *) + with Reduction.NotConvertible -> (isevars, None)) + | _ -> (isevars, None)) + | None -> (isevars, None) + in + (match b with + Some (x, v1, v2) -> + let env1 = push_rel (x,None,v1) env in + let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd' + (Some v2) t2 u2 in + (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', + mkProd (x, v1, t2')) + | None -> + (* Mismatch on t1 and u1 or not a lambda: we eta-expand *) + (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *) + (* has type (name: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', t1') = + inh_conv_coerce_to_fail loc env1 isevars + (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) + in + let (evd'', v2', t2') = + let v2 = + match v with + Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1' + | None -> None + and evd', t2 = + match v1' with + Some v1' -> evd', subst1 v1' t2 + | None -> + let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in + evd', subst1 ev t2 + in + inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2 + in + (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2', + mkProd (name, u1, t2'))) + | _ -> raise NoCoercion)) + + + (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) + let inh_conv_coerce_to loc env isevars cj ((n, t) as _tycon) = +(* (try *) +(* trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ *) +(* Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ *) +(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *) +(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) + match n with + None -> + let (evd', val', type') = + try + inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t + with NoCoercion -> + let sigma = evars_of isevars in + try + coerce_itf loc env isevars (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) -> + (isevars, cj) + + let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) = +(* (try *) +(* trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ *) +(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *) +(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *) +(* Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *) +(* Termops.print_env env); *) +(* with _ -> ()); *) + let nabsinit, nabs = + match abs with + None -> 0, 0 + | Some (init, cur) -> init, cur + in + (* a little more effort to get products is needed *) + try let rels, rng = decompose_prod_n 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 0 (succ nabsinit) rng then ( +(* trace (str "No occur between 0 and " ++ int (succ nabsinit)); *) + let env', t, t' = + let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in + env', rng, lift nabs t' + in + try + pi1 (try inh_conv_coerce_to_fail loc env' isevars 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 + (* trace (str "decompose_prod_n failed"); *) + (* raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *) +end diff --git a/contrib/subtac/subtac_coercion.mli b/contrib/subtac/subtac_coercion.mli new file mode 100644 index 00000000..53a8d213 --- /dev/null +++ b/contrib/subtac/subtac_coercion.mli @@ -0,0 +1 @@ +module Coercion : Coercion.S diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml new file mode 100644 index 00000000..68ab8c46 --- /dev/null +++ b/contrib/subtac/subtac_command.ml @@ -0,0 +1,411 @@ +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 + +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_soapp=false) ?(ltacvars=([],[])) + c = + let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in + let c' = Subtac_utils.rewrite_cases env c' in +(* (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *) + 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 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_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.understand_type (Evd.evars_of !sigma) env (locate_if_isevar (loc_of_rawconstr t) na t) + + +let interp_context sigma env params = + List.fold_left + (fun (env,params) d -> match d with + | LocalRawAssum ([_,na],(CHole _ as t)) -> + let t = interp_binder sigma env na t in + let d = (na,None,t) in + (push_rel d env, d::params) + | LocalRawAssum (nal,t) -> + let t = interp_type sigma env t in + let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in + let ctx = List.rev ctx in + (push_rel_context ctx env, ctx@params) + | LocalRawDef ((_,na),c) -> + let c = interp_constr_judgment sigma env c in + let d = (na, Some c.uj_val, c.uj_type) in + (push_rel d env,d::params)) + (env,[]) params + +(* 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, 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 = + let sigma = Evd.empty in + let isevars = ref (Evd.create_evar_defs sigma) in + let env = Global.env() in + let nc = named_context env in + let nc_len = named_context_length nc 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 = interp_context isevars env bl in + let after, ((argname, _, argtyp) as arg), before = split_args (succ n) 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 + 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 = + (fun x y -> + mkApp (lt_rel, [| subst1 x rconstr_body; + subst1 y rconstr_body |])) + in + let wf_rel = + mkLambda (name "x", argtyp, + mkLambda (name "y", lift 1 argtyp, + wf_rel_fun (mkRel 2) (mkRel 1))) + in + wf_rel, wf_rel_fun , Some rconstr + else rconstr, (fun 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 (mkRel 1) (mkRel (len + 1)))) + in + let top_bl = after @ (arg :: before) in + let intern_bl = after @ (wfarg 1 :: arg :: before) in + let top_env = push_rel_context top_bl env in + let _intern_env = push_rel_context intern_bl env in + let top_arity = interp_type isevars top_env arityc in + let proj = (Lazy.force sig_).Coqlib.proj1 in + let projection = + mkApp (proj, [| argtyp ; + (mkLambda (Name argid', argtyp, + (wf_rel_fun (mkRel 1) (mkRel 3)))) ; + mkRel 1 + |]) + in + (* (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); *) + let intern_arity = substnl [projection] after_length top_arity in +(* (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); *) + let intern_before_env = push_rel_context before env in + let intern_fun_bl = after @ [wfarg 1] in +(* (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *) + let intern_fun_arity = intern_arity in +(* (try debug 2 (str "Intern fun arity: " ++ *) +(* my_print_constr intern_env intern_fun_arity) with _ -> ()); *) + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in + let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in + let fun_bl = after @ (intern_fun_binder :: [arg]) in +(* (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *) + let fun_env = push_rel_context fun_bl intern_before_env in + let fun_arity = interp_type 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 debug 2 (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 _impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits top_env top_arity + else [] + in + let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in + let fix_def = + match measure_fn with + None -> + mkApp (constr_of_reference (Lazy.force fix_sub_ref), + [| argtyp ; + wf_rel ; + make_existential dummy_loc intern_before_env isevars wf_proof ; + prop ; + intern_body_lam |]) + | Some f -> + mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), + [| argtyp ; f ; prop ; + 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 _ = try trace (str "After evar normalization: " ++ spc () ++ *) +(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *) +(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) +(* with _ -> () *) +(* in *) + let evm = non_instanciated_map env isevars in + (* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) + let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in + (* (try trace (str "Generated obligations : "); *) +(* Array.iter *) + (* (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) *) + (* evars; *) + (* with _ -> ()); *) + Subtac_obligations.add_definition recname evars_def fullctyp evars + +let build_mutrec l boxed = + let sigma = Evd.empty and env = Global.env () in + let nc = named_context env in + let nc_len = named_context_length nc in + let lnameargsardef = + (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env protos (f, d))*) + l + in + let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef + and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef + in + (* Build the recursive context and notations for the recursive types *) + let (rec_sign,rec_env,rec_impls,arityl) = + List.fold_left + (fun (sign,env,impls,arl) ((recname, n, bl,arityc,body),_) -> + let isevars = ref (Evd.create_evar_defs sigma) in + let arityc = Command.generalize_constr_expr arityc bl in + let arity = interp_type isevars env arityc in + let impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits env arity + else [] in + let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in + ((recname,None,arity) :: sign, Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl)) + ([],env,[],[]) lnameargsardef in + let arityl = List.rev arityl in + let notations = + List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l) + lnameargsardef [] in + + let recdef = + + (* Declare local notations *) + let fs = States.freeze() in + let def = + try + List.iter (fun (df,c,scope) -> (* No scope for tmp notation *) + Metasyntax.add_notation_interpretation df rec_impls c None) notations; + List.map2 + (fun ((_,_,bl,_,def),_) (isevars, info, arity) -> + match info with + None -> + let def = abstract_constr_expr def bl in + isevars, info, interp_casted_constr isevars rec_env ~impls:([],rec_impls) + def arity + | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) -> + let rec_env = push_rel_context fun_bl rec_env in + let cstr = interp_casted_constr isevars rec_env ~impls:([],rec_impls) + def intern_arity + in isevars, info, it_mkLambda_or_LetIn cstr fun_bl) + lnameargsardef arityl + with e -> + States.unfreeze fs; raise e in + States.unfreeze fs; def + in + let (lnonrec,(namerec,defrec,arrec,nvrec)) = + collect_non_rec env lrecnames recdef arityl nv in + let recdefs = Array.length defrec in + (* Solve remaining evars *) + let rec collect_evars i acc = + if i < recdefs then + let (isevars, info, def) = defrec.(i) in + (* let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *) + let def = evar_nf isevars def in + let isevars = Evd.undefined_evars !isevars in + (* let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *) + let evm = Evd.evars_of isevars in + let _, _, typ = arrec.(i) in + let id = namerec.(i) in + (* 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 evars, def = Eterm.eterm_obligations id nc_len evm def (Some typ) in + collect_evars (succ i) ((id, def, typ, evars) :: acc) + else acc + in + let defs = collect_evars 0 [] in + Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec + +let out_n = function + Some n -> n + | None -> 0 + +let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed = + match lnameargsardef with + | ((id, (n, CWfRec r), bl, typ, body), no) :: [] -> + build_wellfounded (id, out_n n, bl, typ, body) r false no boxed + | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] -> + build_wellfounded (id, out_n n, bl, typ, body) r true no boxed + | l -> + let lnameargsardef = + List.map (fun ((id, (n, ro), bl, typ, body), no) -> + match ro with + CStructRec -> (id, out_n n, bl, typ, body), no + | CWfRec _ | CMeasureRec _ -> + errorlabstrm "Subtac_command.build_recursive" + (str "Well-founded fixpoints not allowed in mutually recursive blocks")) + lnameargsardef + in build_mutrec lnameargsardef boxed + + + diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli new file mode 100644 index 00000000..846e06cf --- /dev/null +++ b/contrib/subtac/subtac_command.mli @@ -0,0 +1,42 @@ +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_soapp:bool -> + ?ltacvars:ltac_sign -> + constr_expr -> constr +val interp_constr : + evar_defs ref -> + env -> constr_expr -> constr +val interp_type : + evar_defs ref -> + env -> + ?impls:full_implicits_env -> + constr_expr -> constr +val interp_casted_constr : + 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 build_recursive : + (fixpoint_expr * decl_notation) list -> bool -> unit diff --git a/contrib/subtac/subtac_errors.ml b/contrib/subtac/subtac_errors.ml new file mode 100644 index 00000000..3bbfe22b --- /dev/null +++ b/contrib/subtac/subtac_errors.ml @@ -0,0 +1,24 @@ +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 new file mode 100644 index 00000000..8d75b9c0 --- /dev/null +++ b/contrib/subtac/subtac_errors.mli @@ -0,0 +1,15 @@ +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_interp_fixpoint.ml b/contrib/subtac/subtac_interp_fixpoint.ml new file mode 100644 index 00000000..bb35833f --- /dev/null +++ b/contrib/subtac/subtac_interp_fixpoint.ml @@ -0,0 +1,154 @@ +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 Topconstr + +open Subtac_coercion +open Subtac_utils +open Coqlib +open Printer +open Subtac_errors +open Context +open Eterm + + +let mkAppExplC (f, args) = CAppExpl (dummy_loc, (None, f), args) + +let mkSubset name typ prop = + mkAppExplC (sig_ref, + [ typ; mkLambdaC ([name], typ, prop) ]) + +let mkProj1 u p x = + mkAppExplC (proj1_sig_ref, [ u; p; x ]) + +let mkProj2 u p x = + mkAppExplC (proj2_sig_ref, [ u; p; x ]) + +let list_of_local_binders l = + let rec aux acc = function + Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, c) :: acc) tl + | Topconstr.LocalRawAssum (nl, c) :: tl -> + aux (List.fold_left (fun acc n -> (n, c) :: acc) acc nl) tl + | [] -> List.rev acc + in aux [] l + +let abstract_constr_expr_bl abs c bl = + List.fold_right (fun (n, t) c -> abs ([n], t, c)) bl c + +let pr_binder_list b = + List.fold_right (fun ((loc, name), t) acc -> Nameops.pr_name name ++ str " : " ++ + Ppconstr.pr_constr_expr t ++ spc () ++ acc) b (mt ()) + + +let rec rewrite_rec_calls l c = c +(* +let rewrite_fixpoint env l (f, decl) = + let (id, (n, ro), bl, typ, body) = f in + let body = rewrite_rec_calls l body in + match ro with + CStructRec -> ((id, (n, ro), bl, typ, body), decl) + | CWfRec wfrel -> + let bls = list_of_local_binders bl in + let _ = trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id id ++ + Ppconstr.pr_binders bl ++ str " : " ++ + Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++ + Ppconstr.pr_constr_expr body) + in + let before, after = list_chop n bls in + let _ = trace (str "Binders before the recursion arg: " ++ spc () ++ + pr_binder_list before ++ str "; after the recursion arg: " ++ + pr_binder_list after) + in + let ((locn, name) as lnid, ntyp), after = match after with + hd :: tl -> hd, tl + | _ -> assert(false) (* Rec arg must be in after *) + in + let nid = match name with + Name id -> id + | Anonymous -> assert(false) (* Rec arg _must_ be named *) + in + let _wfproof = + let _wf_rel = mkAppExplC (well_founded_ref, [ntyp; wfrel]) in + (*make_existential_expr dummy_loc before wf_rel*) + mkRefC lt_wf_ref + in + let nid', accproofid = + let nid = string_of_id nid in + id_of_string (nid ^ "'"), id_of_string ("Acc_" ^ nid) + in + let lnid', laccproofid = (dummy_loc, Name nid'), (dummy_loc, Name accproofid) in + let wf_prop = (mkAppC (wfrel, [ mkIdentC nid'; mkIdentC nid ])) in + let lam_wf_prop = mkLambdaC ([lnid'], ntyp, wf_prop) in + let typnid' = mkSubset lnid' ntyp wf_prop in + let internal_type = + abstract_constr_expr_bl mkProdC + (mkProdC ([lnid'], typnid', + mkLetInC (lnid, mkProj1 ntyp lam_wf_prop (mkIdentC nid'), + abstract_constr_expr_bl mkProdC typ after))) + before + in + let body' = + let body = + (* cast or we will loose some info at pretyping time as body + is a function *) + CCast (dummy_loc, body, CastConv DEFAULTcast, typ) + in + let body' = (* body abstracted by rec call *) + mkLambdaC ([(dummy_loc, Name id)], internal_type, body) + in + mkAppC (body', + [mkLambdaC + ([lnid'], typnid', + mkAppC (mkIdentC id, + [mkProj1 ntyp lam_wf_prop (mkIdentC nid'); + (mkAppExplC (acc_inv_ref, + [ ntyp; wfrel; + mkIdentC nid; + mkIdentC accproofid; + mkProj1 ntyp lam_wf_prop (mkIdentC nid'); + mkProj2 ntyp lam_wf_prop (mkIdentC nid') ])) ]))]) + in + let acctyp = mkAppExplC (acc_ref, [ ntyp; wfrel; mkIdentC nid ]) in + let bl' = + let rec aux acc = function + Topconstr.LocalRawDef _ as x :: tl -> + aux (x :: acc) tl + | Topconstr.LocalRawAssum (bl, typ) as assum :: tl -> + let rec aux' bl' = function + ((loc, name') as x) :: tl -> + if name' = name then + (if tl = [] then [] else [LocalRawAssum (tl, typ)]) @ + LocalRawAssum ([(dummy_loc, Name accproofid)], acctyp) :: + [LocalRawAssum (List.rev (x :: bl'), typ)] + else aux' (x :: bl') tl + | [] -> [assum] + in aux (aux' [] bl @ acc) tl + | [] -> List.rev acc + in aux [] bl + in + let _ = trace (str "Rewrote fixpoint: " ++ Ppconstr.pr_id id ++ + Ppconstr.pr_binders bl' ++ str " : " ++ + Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++ + Ppconstr.pr_constr_expr body') + in (id, (succ n, ro), bl', typ, body'), decl + +*) diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli new file mode 100644 index 00000000..149e7580 --- /dev/null +++ b/contrib/subtac/subtac_interp_fixpoint.mli @@ -0,0 +1,17 @@ +val mkAppExplC : + Libnames.reference * Topconstr.constr_expr list -> Topconstr.constr_expr +val mkSubset : + Names.name Util.located -> + Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr +val mkProj1 : + Topconstr.constr_expr -> + Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr +val mkProj2 : + Topconstr.constr_expr -> + Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr +val list_of_local_binders : + Topconstr.local_binder list -> + (Names.name Util.located * Topconstr.constr_expr) list +val pr_binder_list : + (('a * Names.name) * Topconstr.constr_expr) list -> Pp.std_ppcmds +val rewrite_rec_calls : 'a -> 'b -> 'b diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml new file mode 100644 index 00000000..d6c1772f --- /dev/null +++ b/contrib/subtac/subtac_obligations.ml @@ -0,0 +1,394 @@ +open Printf +open Pp +open Subtac_utils + +open Term +open Names +open Libnames +open Summary +open Libobject +open Entries +open Decl_kinds +open Util +open Evd + +type obligation_info = (Names.identifier * Term.types * Intset.t) array + +type obligation = + { obl_name : identifier; + obl_type : types; + obl_body : constr option; + obl_deps : Intset.t; + } + +type obligations = (obligation array * int) + +type program_info = { + prg_name: identifier; + prg_body: constr; + prg_type: constr; + prg_obligations: obligations; + prg_deps : identifier list; + prg_nvrec : int array; +} + +let assumption_message id = + Options.if_verbose message ((string_of_id id) ^ " is assumed") + +let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC + +let set_default_tactic t = default_tactic := t + +let evar_of_obligation o = { evar_hyps = Global.named_context_val () ; + evar_concl = o.obl_type ; + evar_body = Evar_empty ; + evar_extra = None } + +let subst_deps obls deps t = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + debug 3 (str "Trying to get body of obligation " ++ int x); + let oblb = + try out_some xobl.obl_body + with _ -> + debug 3 (str "Couldn't get body of obligation " ++ int x); + assert(false) + in + Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) + deps t + +let subst_deps_obl obls obl = + let t' = subst_deps 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 _ = + Summary.declare_summary "program-tcc-table" + { Summary.freeze_function = (fun () -> !from_prg); + Summary.unfreeze_function = + (fun v -> from_prg := v); + Summary.init_function = + (fun () -> from_prg := ProgMap.empty); + Summary.survive_module = false; + Summary.survive_section = false } + +open Evd + +let terms_of_evar ev = + match ev.evar_body with + Evar_defined b -> + let nc = Environ.named_context_of_val ev.evar_hyps in + let body = Termops.it_mkNamedLambda_or_LetIn b nc in + let typ = Termops.it_mkNamedProd_or_LetIn ev.evar_concl nc in + body, typ + | _ -> assert(false) + +let rec intset_to = function + -1 -> Intset.empty + | n -> Intset.add n (intset_to (pred n)) + +let subst_body prg = + let obls, _ = prg.prg_obligations in + subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body + +let declare_definition prg = + let body = subst_body prg in + (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ + my_print_constr (Global.env()) body); + with _ -> ()); + let ce = + { const_entry_body = body; + const_entry_type = Some prg.prg_type; + const_entry_opaque = false; + const_entry_boxed = false} + in + let _constant = Declare.declare_constant + prg.prg_name (DefinitionEntry ce,IsDefinition Definition) + in + Subtac_utils.definition_message prg.prg_name + +open Pp +open Ppconstr + +let declare_mutual_definition l = + let len = List.length l in + let namerec = Array.of_list (List.map (fun x -> x.prg_name) l) in + let arrec = + Array.of_list (List.map (fun x -> snd (decompose_prod_n len x.prg_type)) l) + in + let recvec = + Array.of_list + (List.map (fun x -> + let subs = (subst_body x) in + snd (decompose_lam_n len subs)) l) + in + let nvrec = (List.hd l).prg_nvrec in + let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in + let rec declare i fi = + (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++ + my_print_constr (Global.env()) (recvec.(i))); + with _ -> ()); + let ce = + { const_entry_body = mkFix ((nvrec,i),recdecls); + const_entry_type = Some arrec.(i); + const_entry_opaque = false; + const_entry_boxed = true} in + let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint) + in + ConstRef kn + in + let lrefrec = Array.mapi declare namerec in + Options.if_verbose ppnl (recursive_message lrefrec) + +let declare_obligation obl body = + let ce = + { const_entry_body = body; + const_entry_type = Some obl.obl_type; + const_entry_opaque = false; + const_entry_boxed = false} + in + let constant = Declare.declare_constant obl.obl_name + (DefinitionEntry ce,IsProof Property) + in + Subtac_utils.definition_message obl.obl_name; + { obl with obl_body = Some (mkConst constant) } + +let try_tactics obls = + Array.map + (fun obl -> + match obl.obl_body with + None -> + (try + let ev = evar_of_obligation obl in + let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in + declare_obligation obl c + with _ -> obl) + | _ -> obl) + obls + +let red = Reductionops.nf_betaiota + +let init_prog_info n b t deps nvrec obls = + let obls' = + Array.mapi + (fun i (n, t, d) -> + debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); + { obl_name = n ; obl_body = None; + obl_type = red t; + obl_deps = d }) + obls + in + { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); + prg_deps = deps; prg_nvrec = nvrec; } + +let pperror cmd = Util.errorlabstrm "Subtac" cmd +let error s = pperror (str s) + +let get_prog name = + let prg_infos = !from_prg in + match name with + Some n -> + (try ProgMap.find n prg_infos + with Not_found -> error ("No obligations for program " ^ string_of_id n)) + | None -> + (let n = map_cardinal prg_infos in + match n with + 0 -> error "No obligations remaining" + | 1 -> map_first prg_infos + | _ -> error "More than one program with unsolved obligations") + +let obligations_solved prg = (snd prg.prg_obligations) = 0 + +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; + if rem > 0 then ( + Options.if_verbose msgnl (int rem ++ str " obligation(s) remaining"); + ) + else ( + Options.if_verbose msgnl (str "No more obligations remaining"); + match prg'.prg_deps with + [] -> + declare_definition prg'; + from_prg := ProgMap.remove prg.prg_name !from_prg + | 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 + (declare_mutual_definition progs; + from_prg := List.fold_left + (fun acc x -> ProgMap.remove x.prg_name acc) !from_prg progs)) + +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 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 Subtac_utils.goal_proof_kind obl.obl_type + (fun strength gr -> + debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); + let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + update_obls prg obls (pred rem)); + trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); + Pfedit.by !default_tactic + | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + +let subtac_obligation (user_num, name, typ) = + let num = pred user_num in + let prg = get_prog 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)) + + +let obligations_of_evars evars = + let arr = + Array.of_list + (List.map + (fun (n, t) -> + { obl_name = n; + obl_type = t; + obl_body = None; + obl_deps = Intset.empty; + }) evars) + in arr, Array.length arr + +let 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 t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in + obls.(i) <- { obl with obl_body = Some t }; + true + else false + with _ -> false) + +let solve_obligations n tac = + let prg = get_prog n in + 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 + +let add_definition n b t obls = + Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); + let prg = init_prog_info n b t [] (Array.make 0 0) obls in + let obls,_ = prg.prg_obligations in + if Array.length obls = 0 then ( + Options.if_verbose ppnl (str "."); + declare_definition prg; + from_prg := ProgMap.remove prg.prg_name !from_prg) + else ( + let len = Array.length obls in + let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in + from_prg := ProgMap.add n prg !from_prg; + solve_obligations (Some n) !default_tactic) + +let add_mutual_definitions l nvrec = + let deps = List.map (fun (n, b, t, obls) -> n) l in + let upd = List.fold_left + (fun acc (n, b, t, obls) -> + let prg = init_prog_info n b t deps nvrec obls in + ProgMap.add n prg acc) + !from_prg l + in + from_prg := upd; + List.iter (fun x -> solve_obligations (Some x) !default_tactic) deps + +let admit_obligations n = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in + let obls' = + Array.mapi (fun i x -> + match x.obl_body with + None -> + let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in + assumption_message x.obl_name; + { x with obl_body = Some (mkConst kn) } + | Some _ -> x) + obls + in + 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 rec next_obligation n = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in + let i = + array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) + obls + in + if solve_obligation_by_tac prg obls i !default_tactic then ( + update_obls prg obls (pred rem); + next_obligation n + ) else solve_obligation prg i + +open Pp +let show_obligations n = + let prg = get_prog n in + let n = prg.prg_name in + let obls, rem = prg.prg_obligations in + msgnl (int rem ++ str " obligation(s) remaining: "); + Array.iteri (fun i x -> + match x.obl_body with + None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()) + | Some _ -> ()) + obls + diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli new file mode 100644 index 00000000..3981d4c6 --- /dev/null +++ b/contrib/subtac/subtac_obligations.mli @@ -0,0 +1,21 @@ +open Util + +type obligation_info = (Names.identifier * Term.types * Intset.t) array + +val set_default_tactic : Proof_type.tactic -> unit + +val add_definition : Names.identifier -> Term.constr -> Term.types -> + obligation_info -> unit + +val add_mutual_definitions : + (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> 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 -> unit + +val show_obligations : Names.identifier option -> unit + +val admit_obligations : Names.identifier option -> unit diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml new file mode 100644 index 00000000..4d1ac731 --- /dev/null +++ b/contrib/subtac/subtac_pretyping.ml @@ -0,0 +1,156 @@ +(************************************************************************) +(* 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 9563 2007-01-31 09:37:18Z 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 Context +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 evm = evars_of !isevars in + 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 + +let list_split_at index l = + let rec aux i acc = function + hd :: tl when i = index -> (List.rev acc), tl + | hd :: tl -> aux (succ i) (hd :: acc) tl + | [] -> failwith "list_split_at: Invalid argument" + in aux 0 [] l + +open Vernacexpr + +let coqintern evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env +let coqinterp evd env : Topconstr.constr_expr -> Term.constr = Constrintern.interp_constr (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 !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, typ) :: tl -> + let rawtyp = coqintern !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 l c tycon = + let env_binders, binders_rel = env_with_binders env isevars l in + let tycon = + match tycon with + None -> empty_tycon + | Some t -> + let t = coqintern !isevars env_binders t in + let coqt, ttyp = interp env_binders isevars t empty_tycon in + mk_tycon coqt + in + let c = coqintern !isevars env_binders c in + let c = Subtac_utils.rewrite_cases env c in + let coqc, ctyp = interp env_binders isevars c tycon in +(* let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ *) +(* str "Coq type: " ++ my_print_constr env_binders ctyp) *) +(* with _ -> () *) +(* in *) +(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) with _ -> () in *) + + let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel + and fullctyp = it_mkProd_or_LetIn ctyp binders_rel + in + let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in + let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in + +(* let _ = try trace (str "After evar normalization: " ++ spc () ++ *) +(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *) +(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) +(* with _ -> () *) +(* in *) + let evm = non_instanciated_map env isevars in +(* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) + evm, fullcoqc, fullctyp + +open Subtac_obligations + +let subtac_proof env isevars id l c tycon = + let nc = named_context env in + let nc_len = named_context_length nc in + let evm, coqc, coqt = subtac_process env isevars id l c tycon in + let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in + add_definition id def coqt evars diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli new file mode 100644 index 00000000..b62a8766 --- /dev/null +++ b/contrib/subtac/subtac_pretyping.mli @@ -0,0 +1,15 @@ +open Term +open Environ +open Names +open Sign +open Evd +open Global +open Topconstr + +module Pretyping : Pretyping.S + +val subtac_process : env -> evar_defs ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> evar_map * constr * types + +val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> unit diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml new file mode 100644 index 00000000..6244aef3 --- /dev/null +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -0,0 +1,617 @@ +(************************************************************************) +(* 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 9563 2007-01-31 09:37:18Z 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 + + let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t) + + (* 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 + | 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 = type_app (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,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,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 vdefj = + array_map2_i + (fun i ctxt def -> + (* 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 ftys.(i)) 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 fixj = match fixkind with + | RFix (vn,i) -> + let guard_indexes = Array.mapi + (fun i (n,_) -> match n with + | Some n -> n + | None -> + (* Recursive argument was not given by the user : We + check that there is only one inductive argument *) + let ctx = ctxtv.(i) in + let isIndApp t = + isInd (fst (decompose_app (strip_head_cast t))) in + (* This could be more precise (e.g. do some delta) *) + let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in + try (list_unique_index true lb) - 1 + with Not_found -> + Util.user_err_loc + (loc,"pretype", + Pp.str "cannot guess decreasing argument of fix")) + vn + in + let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in + (try check_fix env fix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkFix fix) ftys.(i) + | RCoFix i -> + let cofix = (i,(names,ftys,Array.map j_val vdefj)) 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 = + 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) + 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) -> + let hj = pretype (mk_tycon 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 + let tycon = + option_map + (fun (abs, ty) -> + match abs with + None -> + isevars := Coercion.inh_conv_coerces_to loc env !isevars typ' + (abs, ty); + (abs, ty) + | Some (init, cur) -> + isevars := Coercion.inh_conv_coerces_to loc env !isevars typ' + (abs, ty); + (Some (init, pred cur), ty)) + tycon + 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 ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon 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,c1,c2) -> + 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 + judge_of_abstraction env name j j' + + | RProd(loc,name,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_default_case_info env LetStyle mis 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_default_case_info env LetStyle mis 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_default_case_info env IfStyle mis in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } + + | RCases (loc,po,tml,eqns) -> + Cases.compile_cases loc + ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) + tycon env (* loc *) (po,tml,eqns) + + | RCast(loc,c,k,t) -> + 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 -> + 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 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 + 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 isevars,_ = consider_remaining_unif_problems env !isevars in + let c = nf_evar (evars_of isevars) c in + if fail_evar then check_evars env sigma isevars c; + isevars, 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 true 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 isevars env kind c = + pretype_gen isevars env ([],[]) kind c + + let understand_tcc sigma env ?expected_type:exptyp c = + let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) 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 new file mode 100644 index 00000000..01dee3e9 --- /dev/null +++ b/contrib/subtac/subtac_utils.ml @@ -0,0 +1,707 @@ +open Evd +open Libnames +open Coqlib +open Term +open Names +open Util + +let ($) f x = f x + +(****************************************************************************) +(* Library linking *) + +let contrib_name = "subtac" + +let subtac_dir = [contrib_name] +let fix_sub_module = "FixSub" +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 ["subtac";"FixSub"] "Fix_sub" +let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub" +let lt_ref = make_ref ["Init";"Peano"] "lt" +let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf" + +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 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 = lazy (init_constant ["Logic";"JMeq"] "JMeq") +let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec") +let jmeq_ind_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq") +let jmeq_refl_ref = lazy (init_reference ["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 !Options.debug && n >= debug_level then + msgnl s + else () + else () + +let debug_msg n s = + if debug_on then + if !Options.debug && n >= debug_level then s + else mt () + else mt () + +let trace s = + if debug_on then + if !Options.debug && debug_level > 0 then msgnl s + else () + else () + +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 env isevars c = + let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) 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) 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" + +let non_instanciated_map env evd = + let evm = evars_of !evd in + 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 k) + 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 true (Name n) hyptype in + let conttac = + (fun cont -> + conttac + (tclTHENS tac + ([intros; + (tclTHENSEQ + [constructor_tac (Some 1) 1 + (Rawterm.ImplicitBindings [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 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 rec concatMap f l = + match l with + hd :: tl -> f hd @ concatMap f tl + | [] -> [] + +let list_mapi f = + let rec aux i = function + hd :: tl -> f i hd :: aux (succ i) tl + | [] -> [] + in aux 0 + +(* +let make_discr (loc, po, tml, eqns) = + let mkHole = RHole (dummy_loc, InternalHole) in + + let rec vars_of_pat = function + RPatVar (loc, n) -> (match n with Anonymous -> [] | Name n -> [n]) + | RPatCstr (loc, csrt, pats, _) -> + concatMap vars_of_pat pats + in + let rec constr_of_pat l = function + RPatVar (loc, n) -> + (match n with + Anonymous -> + let n = next_name_away_from "x" l in + RVar n, (n :: l) + | Name n -> RVar n, l) + | RPatCstr (loc, csrt, pats, _) -> + let (args, vars) = + List.fold_left + (fun (args, vars) x -> + let c, vars = constr_of_pat vars x in + c :: args, vars) + ([], l) pats + in + RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars + in + let rec constr_of_pat l = function + RPatVar (loc, n) -> + (match n with + Anonymous -> + let n = next_name_away_from "x" l in + RVar n, (n :: l) + | Name n -> RVar n, l) + | RPatCstr (loc, csrt, pats, _) -> + let (args, vars) = + List.fold_left + (fun (args, vars) x -> + let c, vars = constr_of_pat vars x in + c :: args, vars) + ([], l) pats + in + RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars + in + let constrs_of_pats v l = + List.fold_left + (fun (v, acc) x -> + let x', v' = constr_of_pat v x in + (l', v' :: acc)) + (v, []) l + in + let rec pat_of_pat l = function + RPatVar (loc, n) -> + let n', l = match n with + Anonymous -> + let n = next_name_away_from "x" l in + n, n :: l + | Name n -> n, n :: l + in + RPatVar (loc, Name n'), l + | RPatCstr (loc, cstr, pats, (loc, alias)) -> + let args, vars, s = + List.fold_left (fun (args, vars) x -> + let pat', vars = pat_of_pat vars pat in + pat' :: args, vars) + ([], alias :: l) pats + in RPatCstr (loc, cstr, args, (loc, alias)), vars + in + let pats_of_pats l = + List.fold_left + (fun (v, acc) x -> + let x', v' = pat_of_pat v x in + (v', x' :: acc)) + ([], []) l + in + let eq_of_pat p used c = + let constr, vars' = constr_of_pat used p in + let eq = RApp (dummy_loc, RRef (dummy_loc, Lazy.force eqind_ref), [mkHole; constr; c]) in + vars', eq + in + let eqs_of_pats ps used cstrs = + List.fold_left2 + (fun (vars, eqs) pat c -> + let (vars', eq) = eq_of_pat pat c in + match eqs with + None -> Some eq + | Some eqs -> + Some (RApp (dummy_loc, RRef (dummy_loc, Lazy.force and_ref), [eq, eqs]))) + (used, None) ps cstrs + in + let quantify c l = + List.fold_left + (fun acc name -> RProd (dummy_loc, name, mkHole, acc)) + c l + in + let quantpats = + List.fold_left + (fun (acc, pats) ((loc, idl, cpl, c) as x) -> + let vars, cpl = pats_of_pats cpl in + let l', constrs = constrs_of_pats vars cpl in + let discrs = + List.map (fun (_, _, cpl', _) -> + let qvars, eqs = eqs_of_pats cpl' l' constrs in + let neg = RApp (dummy_loc, RRef (dummy_loc, Lazy.force not_ref), [out_some eqs]) in + let pat_ineq = quantify qvars neg in + + ) + pats in + + + + + + + + (x, pat_ineq)) + in + List.fold_left + (fun acc ((loc, idl, cpl, c0) pat) -> + + + let c' = + List.fold_left + (fun acc (n, t) -> + RLambda (dummy_loc, n, mkHole, acc)) + c eqs_types + in (loc, idl, cpl, c')) + eqns + i +*) +(* let rewrite_cases_aux (loc, po, tml, eqns) = *) +(* let tml = list_mapi (fun i (c, (n, opt)) -> c, *) +(* ((match n with *) +(* Name id -> (match c with *) +(* | RVar (_, id') when id = id' -> *) +(* Name (id_of_string (string_of_id id ^ "'")) *) +(* | _ -> n) *) +(* | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), *) +(* opt)) tml *) +(* in *) +(* let mkHole = RHole (dummy_loc, InternalHole) in *) +(* (\* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), *\) *) +(* (\* [mkHole; c; n]) *\) *) +(* (\* in *\) *) +(* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqdep_ind_ref)), *) +(* [mkHole; c; mkHole; n]) *) +(* in *) +(* let eqs_types = *) +(* List.map *) +(* (fun (c, (n, _)) -> *) +(* let id = match n with Name id -> id | _ -> assert false in *) +(* let heqid = id_of_string ("Heq" ^ string_of_id id) in *) +(* Name heqid, mkeq c (RVar (dummy_loc, id))) *) +(* tml *) +(* in *) +(* let po = *) +(* List.fold_right *) +(* (fun (n,t) acc -> *) +(* RProd (dummy_loc, Anonymous, t, acc)) *) +(* eqs_types (match po with *) +(* Some e -> e *) +(* | None -> mkHole) *) +(* in *) +(* let eqns = *) +(* List.map (fun (loc, idl, cpl, c) -> *) +(* let c' = *) +(* List.fold_left *) +(* (fun acc (n, t) -> *) +(* RLambda (dummy_loc, n, mkHole, acc)) *) +(* c eqs_types *) +(* in (loc, idl, cpl, c')) *) +(* eqns *) +(* in *) +(* let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) +(* [mkHole; c]) *) +(* in *) +(* (\*let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) +(* [mkHole; c]) *) +(* in*\) *) +(* let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in *) +(* let case = RCases (loc,Some po,tml,eqns) in *) +(* let app = RApp (dummy_loc, case, refls) in *) +(* app *) + +(* let rec rewrite_cases c = *) +(* match c with *) +(* RCases _ -> let c' = map_rawconstr rewrite_cases c in *) +(* (match c' with *) +(* | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) *) +(* | _ -> assert(false)) *) +(* | _ -> map_rawconstr rewrite_cases c *) + +(* let rewrite_cases env c = *) +(* let c' = rewrite_cases c in *) +(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) +(* c' *) + +let list_mapi f = + let rec aux i = function + hd :: tl -> f i hd :: aux (succ i) tl + | [] -> [] + in aux 0 + +open Rawterm + +let rewrite_cases_aux (loc, po, tml, eqns) = + let tml' = list_mapi (fun i (c, (n, opt)) -> c, + ((match n with + Name id -> (match c with + | RVar (_, id') when id = id' -> + id, (id_of_string (string_of_id id ^ "Heq_id")) + | RVar (_, id') -> + id', id + | _ -> id_of_string (string_of_id id ^ "Heq_id"), id) + | Anonymous -> + let str = "Heq_id" ^ string_of_int i in + id_of_string str, id_of_string (str ^ "'")), + opt)) tml + in + let mkHole = RHole (dummy_loc, InternalHole) in + let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in + let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eq_ind_ref)), + [mkHole; c; n]) + in + let eqs_types = + List.map + (fun (c, ((id, id'), _)) -> + let heqid = id_of_string ("Heq" ^ string_of_id id) in + Name heqid, mkeq (RVar (dummy_loc, id')) c) + tml' + in + let po = + List.fold_right + (fun (n,t) acc -> + RProd (dummy_loc, Anonymous, t, acc)) + eqs_types (match po with + Some e -> e + | None -> mkHole) + in + let eqns = + List.map (fun (loc, idl, cpl, c) -> + let c' = + List.fold_left + (fun acc (n, t) -> + RLambda (dummy_loc, n, mkHole, acc)) + c eqs_types + in (loc, idl, cpl, c')) + eqns + in + let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), + [mkHole; c]) + in + let refls = List.map (fun (c, ((id, _), _)) -> mk_refl_equal (mkCoerceCast c)) tml' in + let tml'' = List.map (fun (c, ((id, id'), opt)) -> c, (Name id', opt)) tml' in + let case = RCases (loc,Some po,tml'',eqns) in + let app = RApp (dummy_loc, case, refls) in +(* let letapp = List.fold_left (fun acc (c, ((id, id'), opt)) -> RLetIn (dummy_loc, Name id, c, acc)) *) +(* app tml' *) +(* in *) + app + +let rec rewrite_cases c = + match c with + RCases _ -> let c' = map_rawconstr rewrite_cases c in + (match c' with + | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) + | _ -> assert(false)) + | _ -> map_rawconstr rewrite_cases c + +let rewrite_cases env c = c +(* let c' = rewrite_cases c in *) +(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) +(* c' *) + +let id_of_name = function + Name n -> n + | Anonymous -> raise (Invalid_argument "id_of_name") + +let definition_message id = + Options.if_verbose message ((string_of_id id) ^ " is defined") + +let recursive_message v = + match Array.length v with + | 0 -> error "no recursive definition" + | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are recursively defined") + +(* Solve an obligation using tactics, return the corresponding proof term *) +(* +let solve_by_tac ev t = + debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev); + let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in + debug 1 (str "Goal created"); + let ts = Tacmach.mk_pftreestate goal in + debug 1 (str "Got pftreestate"); + let solved_state = Tacmach.solve_pftreestate t ts in + debug 1 (str "Solved goal"); + let _, l = Tacmach.extract_open_pftreestate solved_state in + List.iter (fun (_, x) -> debug 1 (str "left hole of type " ++ my_print_constr (Global.env()) x)) l; + let c = Tacmach.extract_pftreestate solved_state in + debug 1 (str "Extracted term"); + debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c); + c + *) + +let solve_by_tac evi t = + debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi); + let id = id_of_string "H" in + try + Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl + (fun _ _ -> ()); + debug 2 (str "Started proof"); + Pfedit.by (tclCOMPLETE t); + let _,(const,_,_) = Pfedit.cook_proof () in + Pfedit.delete_current_proof (); const.Entries.const_entry_body + with e -> + Pfedit.delete_current_proof(); + 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 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) diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli new file mode 100644 index 00000000..482640f9 --- /dev/null +++ b/contrib/subtac/subtac_utils.mli @@ -0,0 +1,116 @@ +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 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 eq_ind_ref : global_reference lazy_t +val refl_equal_ref : global_reference lazy_t + +val eqdep_ind : constr lazy_t +val eqdep_rec : constr lazy_t +val eqdep_ind_ref : global_reference lazy_t +val eqdep_intro_ref : global_reference lazy_t + +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 -> env -> evar_defs ref -> types -> constr +val make_existential_expr : loc -> 'a -> 'b -> constr_expr +val string_of_hole_kind : hole_kind -> string +val non_instanciated_map : env -> evar_defs ref -> evar_map +val global_kind : logical_kind +val goal_kind : locality_flag * goal_object_kind +val global_proof_kind : logical_kind +val goal_proof_kind : locality_flag * goal_object_kind +val global_fix_kind : logical_kind +val goal_fix_kind : locality_flag * 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 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 rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr +val id_of_name : name -> identifier + +val definition_message : identifier -> unit +val recursive_message : global_reference array -> std_ppcmds + +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 diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v new file mode 100644 index 00000000..7ab720f6 --- /dev/null +++ b/contrib/subtac/test/ListDep.v @@ -0,0 +1,86 @@ +Require Import List. +Require Import Coq.subtac.Utils. + +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. + + Program Fixpoint map_rec ( l' : list U | sub_list l' l ) + { measure l' length } : { 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. + + Obligation 1. + intros. + destruct tl' ; simpl ; simpl in e. + subst x0 tl0. + rewrite <- Heql'. + rewrite e. + auto. + Qed. + + Obligation 2. + simpl. + intros. + destruct l'. + simpl in Heql'. + destruct x0 ; simpl ; try discriminate. + inversion Heql'. + inversion s. + apply H. + auto with datatypes. + Qed. + + + Obligation 3 of map_rec. + simpl. + intros. + rewrite <- Heql'. + simpl ; auto with arith. + Qed. + + Obligation 4. + simpl. + intros. + destruct l'. + simpl in Heql'. + destruct x0 ; simpl ; try discriminate. + inversion Heql'. + subst x tl. + apply sub_list_tl with u ; auto. + Qed. + + Obligation 5. + intros. + rewrite <- Heql' ; auto. + Qed. + + Program Definition map : list V := map_rec l. + Obligation 1. + split ; auto. + Qed. + +End Map_DependentRecursor. + +Extraction map. +Extraction map_rec. + diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v new file mode 100644 index 00000000..b8d13fe6 --- /dev/null +++ b/contrib/subtac/test/ListsTest.v @@ -0,0 +1,76 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) +Require Import Coq.subtac.Utils. +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 ; subtac_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 ; 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. + inversion l0. + Defined. +End Nth. + diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v new file mode 100644 index 00000000..0b40ef82 --- /dev/null +++ b/contrib/subtac/test/Mutind.v @@ -0,0 +1,13 @@ +Program Fixpoint f (a : nat) : nat := + match a with + | 0 => 0 + | S a' => g a a' + end +with g (a b : nat) { struct b } : nat := + match b with + | 0 => 0 + | S b' => f b' + end. + +Check f. +Check g.
\ No newline at end of file diff --git a/contrib/subtac/test/Test1.v b/contrib/subtac/test/Test1.v new file mode 100644 index 00000000..14b80854 --- /dev/null +++ b/contrib/subtac/test/Test1.v @@ -0,0 +1,16 @@ +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 new file mode 100644 index 00000000..a5a8b85f --- /dev/null +++ b/contrib/subtac/test/euclid.v @@ -0,0 +1,27 @@ +Require Import Coq.subtac.Utils. +Require Import Coq.Arith.Compare_dec. +Notation "( x & y )" := (existS _ x y) : core_scope. + +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). + +Require Import Omega. + +Obligations. +Solve Obligations using subtac_simpl ; omega. + +Next Obligation. + assert(x0 * S q' = x0 * q' + x0) 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 new file mode 100644 index 00000000..9ae11088 --- /dev/null +++ b/contrib/subtac/test/id.v @@ -0,0 +1,46 @@ +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 new file mode 100644 index 00000000..4764037d --- /dev/null +++ b/contrib/subtac/test/measure.v @@ -0,0 +1,24 @@ +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. +Require Import Coq.Arith.Compare_dec. + +Require Import Coq.subtac.Utils. + +Fixpoint size (a : nat) : nat := + match a with + 0 => 1 + | S n => S (size n) + end. + +Program Fixpoint test_measure (a : nat) {measure a size} : nat := + match a with + | S (S n) => S (test_measure n) + | x => x + end. +subst. +unfold n0. +auto with arith. +Qed. + +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 new file mode 100644 index 00000000..aaefd8cc --- /dev/null +++ b/contrib/subtac/test/rec.v @@ -0,0 +1,65 @@ +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/wf.v b/contrib/subtac/test/wf.v new file mode 100644 index 00000000..49fec2b8 --- /dev/null +++ b/contrib/subtac/test/wf.v @@ -0,0 +1,48 @@ +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/cic2Xml.ml b/contrib/xml/cic2Xml.ml new file mode 100644 index 00000000..f04a03f9 --- /dev/null +++ b/contrib/xml/cic2Xml.ml @@ -0,0 +1,17 @@ +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 index d820f9e5..ff07c3c4 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -64,7 +64,7 @@ let get_uri_of_var v pvars = in let rec search_in_open_sections = function - [] -> Util.error "Variable not found" + [] -> 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 @@ -83,16 +83,28 @@ let get_uri_of_var v pvars = ;; type tag = - Constant - | Inductive - | Variable + 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 - Constant -> "con" - | Inductive -> "ind" - | Variable -> "var" + TConstant -> "con" + | TInductive -> "ind" + | TVariable -> "var" ;; exception FunctorsXMLExportationNotImplementedYet;; @@ -147,23 +159,24 @@ let token_list_of_path dir id tag = 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 kn tag = +let token_list_of_kernel_name tag = let module N = Names in let module LN = Libnames in - let dir = match tag with - | Variable -> - Lib.cwd () - | Constant -> - Lib.library_part (LN.ConstRef kn) - | Inductive -> - Lib.library_part (LN.IndRef (kn,0)) + 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 - let id = N.id_of_label (N.label kn) in - token_list_of_path dir id tag + token_list_of_path dir id (etag_of_tag tag) ;; -let uri_of_kernel_name kn tag = - let tokens = token_list_of_kernel_name kn tag in +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 = @@ -228,11 +241,11 @@ let typeur sigma metamap = Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) | T.Const c -> let cb = Environ.lookup_constant c env in - T.body_of_type cb.Declarations.const_type - | T.Evar ev -> Instantiate.existential_type sigma ev - | T.Ind ind -> T.body_of_type (Inductive.type_of_inductive env ind) + Typeops.type_of_constant_type env (cb.Declarations.const_type) + | T.Evar ev -> Evd.existential_type sigma ev + | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind) | T.Construct cstr -> - T.body_of_type (Inductive.type_of_constructor env cstr) + T.body_of_type (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) @@ -250,7 +263,7 @@ let typeur sigma metamap = | 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.Cast (c,_, t) -> t | T.Sort _ | T.Prod _ -> match sort_of env cstr with Coq_sort T.InProp -> T.mkProp @@ -260,7 +273,7 @@ let typeur sigma metamap = 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.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) -> @@ -270,7 +283,7 @@ let typeur sigma metamap = | 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 Environ.ImpredicativeSet -> s + 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*) @@ -282,7 +295,7 @@ let typeur sigma metamap = 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.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 @@ -375,7 +388,7 @@ 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.prterm tt)) ; assert false +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. *) @@ -384,19 +397,33 @@ Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-ty {D.synthesized = Reductionops.nf_beta (CPropRetyping.get_type_of env evar_map - (Evarutil.refresh_universes tt)) ; + (Termops.refresh_universes tt)) ; D.expected = None} in (* Debugging only: print_endline "TERMINE:" ; flush stdout ; -Pp.ppnl (Printer.prterm tt) ; flush stdout ; +Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ; print_endline "TIPO:" ; flush stdout ; -Pp.ppnl (Printer.prterm synthesized) ; 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 = get_sort_family_of env evar_map synthesized in + 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 ; *) @@ -441,7 +468,7 @@ print_endline "PASSATO" ; flush stdout ; let subst,residual_args,uninst_vars = let variables,basedir = try - let g = Libnames.reference_of_constr h in + let g = Libnames.global_of_constr h in let sp = match g with Libnames.ConstructRef ((induri,_),_) @@ -533,7 +560,7 @@ print_endline "PASSATO" ; flush stdout ; (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) -> + | T.Cast (v,_, t) -> Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; if is_a_Prop innersort then add_inner_type fresh_id'' ; @@ -670,7 +697,7 @@ print_endline "PASSATO" ; flush stdout ; let compute_result_if_eta_expansion_not_required subst residual_args = - let residual_args_not_empty = List.length residual_args > 0 in + let residual_args_not_empty = residual_args <> [] in let h' = if residual_args_not_empty then aux' env idrefs ~subst:(None,subst) h @@ -695,7 +722,7 @@ print_endline "PASSATO" ; flush stdout ; 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 kn Constant)) + A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn))) in let (_,subst') = subst in explicit_substitute_and_eta_expand_if_required tt [] @@ -703,7 +730,7 @@ print_endline "PASSATO" ; flush stdout ; 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 kn Inductive), i) + 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 [] @@ -715,7 +742,7 @@ print_endline "PASSATO" ; flush stdout ; add_inner_type fresh_id'' ; let compute_result_if_eta_expansion_not_required _ _ = A.AConstruct - (fresh_id'', subst, (uri_of_kernel_name kn Inductive), i, j) + (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j) in let (_,subst') = subst in explicit_substitute_and_eta_expand_if_required tt [] @@ -729,7 +756,7 @@ print_endline "PASSATO" ; flush stdout ; Array.fold_right (fun x i -> (aux' env idrefs x)::i) a [] in A.ACase - (fresh_id'', (uri_of_kernel_name kn Inductive), i, + (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 ; diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml index f0e3f5e3..c7d3b4ff 100644 --- a/contrib/xml/doubleTypeInference.ml +++ b/contrib/xml/doubleTypeInference.ml @@ -19,7 +19,7 @@ let prerr_endline _ = ();; let cprop = let module N = Names in - N.make_kn + N.make_con (N.MPfile (Libnames.dirpath_of_string "CoRN.algebra.CLogic")) (N.make_dirpath []) @@ -40,13 +40,13 @@ let whd_betadeltaiotacprop env evar_map ty = Conv_oracle.set_opaque_const cprop; prerr_endline "###whd_betadeltaiotacprop:" ; let xxx = -(*Pp.msgerr (Printer.prterm_env env ty);*) +(*Pp.msgerr (Printer.pr_lconstr_env env ty);*) prerr_endline ""; - Tacred.reduction_of_redexp red_exp env evar_map ty + (fst (Redexpr.reduction_of_red_expr red_exp)) env evar_map ty in prerr_endline "###FINE" ; (* -Pp.msgerr (Printer.prterm_env env xxx); +Pp.msgerr (Printer.pr_lconstr_env env xxx); *) prerr_endline ""; Conv_oracle.set_transparent_const cprop; @@ -89,10 +89,11 @@ let double_type_of env sigma cstr expectedty subterms_to_types = "DoubleTypeInference.double_type_of: found a non-instanciated goal" | T.Evar ((n,l) as ev) -> - let ty = Unshare.unshare (Instantiate.existential_type sigma ev) in + 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 = (Evd.map sigma n).Evd.evar_hyps 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 [],[] -> () @@ -121,13 +122,13 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Typeops.judge_of_variable env id | T.Const c -> - E.make_judge cstr (E.constant_type env c) + E.make_judge cstr (Typeops.type_of_constant env c) | T.Ind ind -> - E.make_judge cstr (Inductive.type_of_inductive env ind) + E.make_judge cstr (Inductiveops.type_of_inductive env ind) | T.Construct cstruct -> - E.make_judge cstr (Inductive.type_of_constructor env cstruct) + E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) | T.Case (ci,p,c,lf) -> let expectedtype = @@ -230,11 +231,11 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let j3 = execute env1 sigma c3 None in Typeops.judge_of_letin env name j1 j2 j3 - | T.Cast (c,t) -> + | T.Cast (c,k,t) -> let cj = execute env sigma c (Some (Reductionops.nf_beta 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 tj in + let j, _ = Typeops.judge_of_cast env cj k tj in j in let synthesized = E.j_type judgement in @@ -244,19 +245,20 @@ let double_type_of env sigma cstr expectedty subterms_to_types = None -> (* No expected type *) {synthesized = synthesized' ; expected = None}, synthesized - (*CSC: in HELM we did not considered Casts to be irrelevant. *) - (*CSC: does it really matter? (eq_constr is up to casts) *) | Some ty when Term.eq_constr synthesized' ty -> - (* The expected type is synthactically equal to *) - (* the synthesized type. Let's forget it. *) - {synthesized = synthesized' ; expected = None}, synthesized + (* 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.prterm cstr)) ; flush stdout ) ; + (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 diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli index 33d3e5cd..2e14b558 100644 --- a/contrib/xml/doubleTypeInference.mli +++ b/contrib/xml/doubleTypeInference.mli @@ -14,7 +14,7 @@ type types = { synthesized : Term.types; expected : Term.types option; } -val cprop : Names.kernel_name +val cprop : Names.constant val whd_betadeltaiotacprop : Environ.env -> Evd.evar_map -> Term.constr -> Term.constr diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml index 165a456d..30dc7b71 100644 --- a/contrib/xml/proof2aproof.ml +++ b/contrib/xml/proof2aproof.ml @@ -32,7 +32,7 @@ let nf_evar sigma ~preserve = 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,c2) -> T.mkCast (aux c1, aux c2) + | 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) @@ -41,14 +41,14 @@ let nf_evar sigma ~preserve = 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,_) -> + | 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.in_dom sigma e & Evd.is_defined sigma e -> - aux (Instantiate.existential_value sigma (e,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)) -> @@ -63,21 +63,24 @@ let nf_evar sigma ~preserve = (* 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} -> + 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.Prim prim -> PT.Prim prim - | PT.Change_evars -> PT.Change_evars - | PT.Tactic (tactic_expr, pf) -> - PT.Tactic (tactic_expr, unshare_proof_tree pf) - in + 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} + {PT.open_subgoals = status ; + PT.goal = goal ; + PT.ref = unshared_ref} ;; module ProofTreeHash = @@ -93,7 +96,7 @@ module ProofTreeHash = let extract_open_proof sigma pf = let module PT = Proof_type in let module L = Logic in - let sigma = ref sigma 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 @@ -103,48 +106,51 @@ let extract_open_proof sigma pf = {PT.ref=Some(PT.Prim _,_)} as pf -> L.prim_extractor proof_extractor vl pf - | {PT.ref=Some(PT.Tactic (_,hidden_proof),spfl)} -> + | {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=Some(PT.Change_evars,[pf])} -> (proof_extractor vl) pf - | {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 = Util.list_index id vl in (n,id) + 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 goal.Evd.evar_hyps) in + (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 = - List.map - (fun (_,id) -> Sign.lookup_named id goal.Evd.evar_hyps) - sorted_rels + 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 sigma',evar = - Evarutil.new_isevar_sign env !sigma goal.Evd.evar_concl evar_instance - in - sigma := sigma' ; + (* 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 !sigma ~preserve:(function e -> S.mem e !unshared_constrs) 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) @@ -152,14 +158,15 @@ let extract_open_proof sigma pf = in (*CSC: debugging stuff to be removed *) if ProofTreeHash.mem proof_tree_to_constr node then - Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") (Refiner.print_proof !sigma [] node)) ; + 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, !sigma, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, + (pfterm, Evd.evars_of !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, unshared_pf) ;; diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index b9b66774..9afd07a6 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -46,7 +46,8 @@ let constr_to_xml obj sigma env = 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 real_named_context env) in + (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 @@ -66,9 +67,9 @@ 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.prterm_env rel_env obj') ; +Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ; Pp.ppnl (Pp.str "RAW-TERM:") ; -Pp.ppnl (Printer.prterm obj') ; +Pp.ppnl (Printer.pr_lconstr obj') ; Xml.xml_empty "MISSING TERM" [] (*; raise e*) *) ;; @@ -92,10 +93,10 @@ let string_of_prim_rule x = match x with | Proof_type.ThinBody _-> "ThinBody" | Proof_type.Move (_,_,_) -> "Move" | Proof_type.Rename (_,_) -> "Rename" - + | Proof_type.Change_evars -> "Change_evars" let - print_proof_tree curi sigma0 pf proof_tree_to_constr + 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 @@ -119,7 +120,7 @@ in with _ -> Pp.ppnl (Pp.(++) (Pp.str "The_generated_term_is_not_a_subterm_of_the_final_lambda_term") -(Printer.prterm constr)) ; +(Printer.pr_lconstr constr)) ; None in let rec aux node old_hyps = @@ -140,7 +141,7 @@ Pp.ppnl (Pp.(++) (Pp.str (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) | {PT.goal=goal; - PT.ref=Some(PT.Tactic (tactic_expr,hidden_proof),nodes)} -> + 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] *) @@ -155,7 +156,7 @@ Pp.ppnl (Pp.(++) (Pp.str aux flat_proof old_hyps | _ -> (****** la tactique employee *) - let prtac = if !Options.v7 then Pptactic.pr_tactic else Pptacticnew.pr_tactic (Global.env()) in + 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 @@ -164,10 +165,7 @@ Pp.ppnl (Pp.(++) (Pp.str let {Evd.evar_concl=concl; Evd.evar_hyps=hyps}=goal in - let rc = (Proof_trees.rc_of_gc sigma0 goal) in - let sigma = Proof_trees.get_gc rc in - let hyps = Proof_trees.get_hyps rc in - let env= Proof_trees.get_env rc in + let env = Global.env_of_context hyps in let xgoal = X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in @@ -183,17 +181,19 @@ Pp.ppnl (Pp.(++) (Pp.str (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)) hyps in + 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 hyps)>] + [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] end - | {PT.ref=Some(PT.Change_evars,nodes)} -> - X.xml_nempty "Change_evars" of_attribute - (List.fold_left - (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) + | {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 diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4 index d0c64f30..e2d04cb7 100644 --- a/contrib/xml/xml.ml4 +++ b/contrib/xml/xml.ml4 @@ -31,8 +31,7 @@ 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 strm fn = - let channel = ref stdout in +let pp_ch strm channel = let rec pp_r m = parser [< 'Str a ; s >] -> @@ -58,16 +57,22 @@ let pp strm fn = and print_spaces m = for i = 1 to m do fprint_string " " done and fprint_string str = - output_string !channel str + output_string channel str in + pp_r 0 strm +;; + + +let pp strm fn = match fn with Some filename -> let filename = filename ^ ".xml" in - channel := open_out filename ; - pp_r 0 strm ; - close_out !channel ; + let ch = open_out filename in + pp_ch strm ch; + close_out ch ; print_string ("\nWriting on file \"" ^ filename ^ "\" was succesful\n"); flush stdout | None -> - pp_r 0 strm + pp_ch strm stdout ;; + diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli index e65e6c81..38a4e01c 100644 --- a/contrib/xml/xml.mli +++ b/contrib/xml/xml.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id: xml.mli,v 1.5.2.2 2004/07/16 19:30:15 herbelin Exp $ i*) +(*i $Id: xml.mli 6681 2005-02-04 18:20:16Z herbelin $ i*) (* Tokens for XML cdata, empty elements and not-empty elements *) (* Usage: *) @@ -31,6 +31,8 @@ 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 *) diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 9fba5474..f286d2c8 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -38,6 +38,8 @@ 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 *) @@ -60,6 +62,8 @@ let extract_nparams pack = 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 *) @@ -177,12 +181,12 @@ let rec join_dirs cwd = join_dirs newcwd tail ;; -let filename_of_path xml_library_root kn tag = +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 kn tag in + let tokens = Cic2acic.token_list_of_kernel_name tag in Some (join_dirs xml_library_root' tokens) ;; @@ -210,7 +214,6 @@ let theory_filename xml_library_root = None -> None (* stdout *) | Some xml_library_root' -> let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in - let hd = List.hd toks 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") @@ -286,7 +289,7 @@ let find_hyps t = | T.Meta _ | T.Evar _ | T.Sort _ -> l - | T.Cast (te,ty) -> aux (aux l te) ty + | 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 @@ -355,11 +358,11 @@ let mk_current_proof_obj is_a_variable id bo ty evar_map env = (* 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 evar_hyps) + 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)) - ) (Evd.non_instantiated evar_map) + ) (Evarutil.non_instantiated evar_map) in let id' = Names.string_of_id id in if metasenv = [] then @@ -392,21 +395,21 @@ let mk_constant_obj id bo ty variables hyps = ty,params) ;; -let mk_inductive_obj sp packs variables hyps finite = +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 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 ; - D.mind_nf_arity=arity} = p + D.mind_typename=typename } = p in - let lc = Inductive.arities_of_constructors (Global.env ()) (sp,!tyno) 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 @@ -430,16 +433,10 @@ let theory_output_string ?(do_not_quote = false) s = Buffer.add_string theory_buffer s ;; -let kind_of_theorem = function - | Decl_kinds.Theorem -> "Theorem" - | Decl_kinds.Lemma -> "Lemma" - | Decl_kinds.Fact -> "Fact" - | Decl_kinds.Remark -> "Remark" - let kind_of_global_goal = function - | Decl_kinds.IsGlobal Decl_kinds.DefinitionBody -> "DEFINITION","InteractiveDefinition" - | Decl_kinds.IsGlobal (Decl_kinds.Proof k) -> "THEOREM",kind_of_theorem k - | Decl_kinds.IsLocal -> assert false + | 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", @@ -454,9 +451,9 @@ let kind_of_variable id = | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption" | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis" | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture" - | DK.IsDefinition -> "VARIABLE","LocalDefinition" - | DK.IsConjecture -> "VARIABLE","Conjecture" - | DK.IsProof DK.LocalStatement -> "VARIABLE","LocalFact" + | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition" + | DK.IsProof _ -> "VARIABLE","LocalFact" + | _ -> Util.anomaly "Unsupported variable kind" ;; let kind_of_constant kn = @@ -465,9 +462,10 @@ let kind_of_constant kn = | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" | DK.IsAssumption DK.Conjectural -> "AXIOM","Conjecture" - | DK.IsDefinition -> "DEFINITION","Definition" - | DK.IsConjecture -> "THEOREM","Conjecture" - | DK.IsProof thm -> "THEOREM",kind_of_theorem thm + | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" + | DK.IsDefinition DK.Example -> "DEFINITION","Example" + | DK.IsDefinition _ -> Util.anomaly "Unsupported constant kind" + | DK.IsProof thm -> "THEOREM",DK.string_of_theorem_kind thm ;; let kind_of_global r = @@ -476,7 +474,7 @@ let kind_of_global r = match r with | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> let isrecord = - try let _ = Recordops.find_structure kn in true + 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 @@ -509,7 +507,7 @@ let print internal glob_ref kind xml_library_root = let module Ln = Libnames in (* Variables are the identifiers of the variables in scope *) let variables = search_variables () in - let kn,tag,obj = + let tag,obj = match glob_ref with Ln.VarRef id -> let sp = Declare.find_section_variable id in @@ -519,23 +517,25 @@ let print internal glob_ref kind xml_library_root = N.make_kn mod_path dir_path (N.label_of_id (Ln.basename sp)) in let (_,body,typ) = G.lookup_named id in - kn,Cic2acic.Variable,mk_variable_obj id body typ + Cic2acic.Variable kn,mk_variable_obj id body typ | Ln.ConstRef kn -> - let id = N.id_of_label (N.label kn) in + 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 - kn,Cic2acic.Constant,mk_constant_obj id val0 typ variables hyps + 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 {D.mind_packets=packs ; + let mib = G.lookup_mind kn in + let {D.mind_nparams=nparams; + D.mind_packets=packs ; D.mind_hyps=hyps; - D.mind_finite=finite} = G.lookup_mind kn in - kn,Cic2acic.Inductive, - mk_inductive_obj kn packs variables hyps finite + D.mind_finite=finite} = mib in + Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite | Ln.ConstructRef _ -> - Util.anomaly ("print: this should not happen") + Util.error ("a single constructor cannot be printed in XML") in - let fn = filename_of_path xml_library_root kn tag in - let uri = Cic2acic.uri_of_kernel_name kn tag 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 ;; @@ -548,28 +548,27 @@ let print_ref qid fn = (* 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 str = Names.string_of_id id in 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 kn = Lib.make_kn id in let env = Global.env () in let obj = - mk_current_proof_obj (kind = Decl_kinds.IsLocal) id val0 typ evar_map env in + mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in let uri = match kind with - Decl_kinds.IsLocal -> + Decl_kinds.Local, _ -> let uri = "cic:/" ^ String.concat "/" - (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.Variable) in + (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.IsGlobal _ -> - let uri = Cic2acic.uri_of_declaration id Cic2acic.Constant in + | 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 @@ -610,7 +609,7 @@ let _ = let _ = Declare.set_xml_declare_constant - (function (internal,(sp,kn)) -> + (function (internal,kn) -> match !proof_to_export with None -> print internal (Libnames.ConstRef kn) (kind_of_constant kn) @@ -618,9 +617,9 @@ let _ = | 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 kn Cic2acic.Constant in + let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in show_pftreestate internal fn pftreestate - (Names.id_of_label (Names.label kn)) ; + (Names.id_of_label (Names.con_label kn)) ; proof_to_export := None) ;; @@ -675,7 +674,7 @@ let _ = let dot = if fn.[0]='/' then "." else "" in command ("mv "^dir^"/"^dot^"*.html "^fn^".xml "); command ("rm "^fn^".v"); - print_string("\nWriting on file \"" ^ fn ^ ".xml\" was succesful\n")) + print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n")) ofn) ;; diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli index 9a7464bd..7c0d31a1 100644 --- a/contrib/xml/xmlcommand.mli +++ b/contrib/xml/xmlcommand.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id: xmlcommand.mli,v 1.18.2.2 2004/07/16 19:30:15 herbelin Exp $ i*) +(*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 *) diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4 index 2bc686f7..496debe1 100644 --- a/contrib/xml/xmlentries.ml4 +++ b/contrib/xml/xmlentries.ml4 @@ -14,7 +14,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: xmlentries.ml4,v 1.12.2.2 2004/07/16 19:30:15 herbelin Exp $ *) +(* $Id: xmlentries.ml4 5920 2004-07-16 20:01:26Z herbelin $ *) open Util;; open Vernacinterp;; |