diff options
Diffstat (limited to 'contrib')
231 files changed, 19303 insertions, 4292 deletions
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml index e73a6221..3e2d11a2 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 7298 2005-08-17 12:56:38Z 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 +let init_size=5 -type pa_constructor= - {head_constr: int; - arity:int; - nhyps:int; - args:int list; - term_head:int} - - -module PacMap=Map.Make(struct type t=int*int let compare=compare end) - -type term= - Symb of constr - | Appli of term*term - | Constructor of constructor*int*int (* constructor arity+ nhyps *) +let cc_verbose=ref false -type rule= - Congruence - | Axiom of identifier - | Injection of int*int*int*int (* terms+head+arg position *) +let debug msg (stdpp:std_ppcmds) = + if !cc_verbose then msg stdpp -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 *) @@ -68,290 +56,452 @@ module ST=struct let query sign st=Hashtbl.find st.toterm sign - 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} +module PacMap=Map.Make(struct + type t=pa_constructor + let compare=Pervasives.compare end) - type cl = Rep of representative| Eqto of int*equality +type cinfo= + {ci_constr: constructor; (* inductive type *) + ci_arity: int; (* # args *) + ci_nhyps: int} (* # projectable args *) - type vertex = Leaf| Node of (int*int) +type term= + Symb of constr + | Eps + | Appli of term*term + | Constructor of cinfo (* constructor arity + nhyps *) - type node = - {clas:cl; - vertex:vertex; - term:term; - mutable node_constr: int PacMap.t} +type rule= + Congruence + | Axiom of identifier * bool + | Injection of int * pa_constructor * int * pa_constructor * int - type t={mutable size:int; - map:(int,node) Hashtbl.t; - syms:(term,int) Hashtbl.t; - sigtable:ST.t} +type from= + Goal + | Hyp of identifier + | HeqG of identifier + | HeqnH of identifier * identifier - let empty ():t={size=0; - map=Hashtbl.create init_size; - syms=Hashtbl.create init_size; - sigtable=ST.empty ()} +type 'a eq = {lhs:int;rhs:int;rule:'a} - 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 equality = rule eq + +type disequality = from eq - let get_constructor uf i= - match (Hashtbl.find uf.map i).term with - Constructor (cstr,_,_)->cstr - | _ -> anomaly "get_constructor: not a constructor" +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 constructors: int PacMap.t} (*pac -> term = app(constr,t) *) + +type cl = Rep of representative| Eqto of int*equality + +type vertex = Leaf| Node of (int*int) + +type node = + {mutable clas:cl; + mutable cpath: int; + vertex:vertex; + term:term} + +type forest= + {mutable max_size:int; + mutable size:int; + mutable map: node array; + axioms: (identifier,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_constructor) Queue.t; + mutable diseq: disequality list; + mutable pa_classes: Intset.t} + +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 ():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=[]; + pa_classes=Intset.empty} + +let forest state = state.uf + +let compress_path uf i j = uf.map.(j).cpath<-i + +let rec find_aux uf visited i= + let j = uf.map.(i).cpath in + if j<0 then let _ = List.iter (compress_path uf i) visited in i else + find_aux uf (i::visited) j + +let find uf i= find_aux uf [] i + +let get_representative uf i= + match uf.map.(i).clas with + Rep r -> r + | _ -> anomaly "get_representative: not a representative" + +let find_pac uf i pac = + PacMap.find pac (get_representative uf i).constructors + +let get_constructor_info uf i= + match uf.map.(i).term with + Constructor cinfo->cinfo + | _ -> anomaly "get_constructor: not a constructor" + +let size uf i= + (get_representative uf i).nfathers +let axioms uf = uf.axioms - let fathers uf i= - (get_representative uf i).fathers - - let size uf i= - (get_representative uf i).nfathers +let epsilons uf = uf.epsilons - let add_father uf i t= - let r=get_representative uf i in - r.nfathers<-r.nfathers+1; - r.fathers<-t::r.fathers +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 pac_map uf i= - (get_representative uf i).constructors +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 - let pac_arity uf i sg= - (PacMap.find sg (get_representative uf i).constructors).arity +exception Discriminable of int * pa_constructor * int * pa_constructor - 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 - - 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 +let append_pac t p = + {p with arity=pred p.arity;args=t::p.args} + +let tail_pac p= + {p with arity=succ p.arity;args=List.tl p.args} + +let add_pac rep pac t = + if not (PacMap.mem pac rep.constructors) then + rep.constructors<-PacMap.add pac t rep.constructors + +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 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 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 pm im= - {nfathers=0; - fathers=[]; - constructors=pm; - inductives=im} - - let rec add uf t= +let new_representative ()= + {nfathers=0; + lfathers=Intset.empty; + fathers=Intset.empty; + inductive_status=Unknown; + constructors=PacMap.empty} + +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 _ | 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 pac = + {cnode= b; + arity= cinfo.ci_arity; + args=[]} in + Queue.add (b,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 id s t= + let i = add_term state s in + let j = add_term state t in + Queue.add {lhs=i;rhs=j;rule=Axiom(id,false)} state.combine; + Hashtbl.add state.uf.axioms id (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 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,pac) state.marks) r1.constructors; + 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 cpl,Total _ -> Queue.add cpl 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,append_pac v pac) state.marks) + rep.constructors; + 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_mark t pac 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 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 + +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 - -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 check_equal uf (i1,i2) = UF.find uf i1 = UF.find uf i2 - -let find_contradiction uf diseq = - List.find (fun (id,cpl) -> check_equal uf cpl) diseq - + 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 + with Queue.Empty -> + try + let (t,m) = Queue.take state.marks in + process_mark t m state + with Queue.Empty -> + let t = Intset.choose state.terms in + state.terms<-Intset.remove t state.terms; + update t state + +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 + +let rec execute first_run state = + debug msgnl (str "Executing ... "); + try + while true do + one_step state + done; + anomaly "keep out of here" + with + Discriminable(s,spac,t,tpac) -> + Some + begin + if first_run then + Discrimination (s,spac,t,tpac) + else + Incomplete + end + | Not_found -> + 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 None + | Some dis -> Some + begin + if first_run then + Contradiction dis + else + Incomplete + end diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli index 47cdb3ea..74132811 100644 --- a/contrib/cc/ccalgo.mli +++ b/contrib/cc/ccalgo.mli @@ -6,15 +6,109 @@ (* * 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 7298 2005-08-17 12:56:38Z 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 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 identifier * bool + | Injection of int * pa_constructor * int * pa_constructor * int + +type from= + Goal + | Hyp of identifier + | HeqG of identifier + | HeqnH of identifier * identifier + +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 debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit + +val forest : state -> forest + +val axioms : forest -> (identifier, term * term) Hashtbl.t + +val epsilons : forest -> pa_constructor list + +val empty : unit -> state + +val add_term : state -> term -> int + +val add_equality : state -> identifier -> term -> term -> unit + +val add_disequality : state -> from -> term -> term -> 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 + +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 +173,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..1200dc2e 100644 --- a/contrib/cc/ccproof.ml +++ b/contrib/cc/ccproof.ml @@ -6,7 +6,7 @@ (* * 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 7298 2005-08-17 12:56:38Z corbinea $ *) (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) @@ -51,8 +51,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 +60,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 +109,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 +124,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..18c745bf 100644 --- a/contrib/cc/ccproof.mli +++ b/contrib/cc/ccproof.mli @@ -6,7 +6,7 @@ (* * 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 7298 2005-08-17 12:56:38Z corbinea $ *) open Ccalgo open Names @@ -19,27 +19,12 @@ type 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 ] + (identifier, (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..4a719f38 --- /dev/null +++ b/contrib/cc/cctac.ml @@ -0,0 +1,336 @@ +(************************************************************************) +(* 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 7909 2006-01-21 11:09:18Z herbelin $ *) + +(* This file is the interface between the c-c algorithm and Coq *) + +open Evd +open Proof_type +open Names +open Libnames +open Nameops +open Inductiveops +open Declarations +open Term +open Termops +open Tacmach +open Tactics +open Tacticals +open 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} + | _ ->(Symb t) + +(* 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 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 + `Other (decompose_term env term) + | _ -> atom_of_constr env term + +(* rebuild a term from applicative format *) + +let rec make_term = function + Symb s->s + | Eps -> anomaly "epsilon constant has no value" + | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Appli (s1,s2)-> + make_app [(make_term s2)] s1 +and make_app l=function + Appli (s1,s2)->make_app ((make_term s2)::l) s1 + | other -> applistc (make_term other) l + +(* store all equalities from the context *) + +let rec make_prb gls additionnal_terms = + let env=pf_env gls in + let state = empty () 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 + match litteral_of_constr env e with + `Eq (t,a,b) -> add_equality state id a b + | `Neq (t,a,b) -> add_disequality state (Hyp id) a b + | `Other ph -> + List.iter + (fun (idn,nh) -> + add_disequality state (HeqnH (id,idn)) ph nh) + !neg_hyps; + pos_hyps:=(id,ph):: !pos_hyps + | `Nother nh -> + List.iter + (fun (idp,ph) -> + add_disequality state (HeqnH (idp,id)) ph nh) + !pos_hyps; + neg_hyps:=(id,nh):: !neg_hyps + 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 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,[|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=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,[|intype;outtype;proj;cti;ctj|]) in + tclTHEN (apply injt) (proof_tac axioms prf) gls) + +let refute_tac axioms id t1 t2 p gls = + let tt1=make_term t1 and tt2=make_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 (mkVar id,[|mkVar hid|]) in + tclTHENS (true_cut (Name hid) neweq) + [proof_tac axioms p; simplest_elim false_t] gls + +let convert_to_goal_tac axioms id t1 t2 p gls = + let tt1=make_term t1 and tt2=make_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;mkVar id;tt2;mkVar e|]) in + tclTHENS (true_cut (Name e) neweq) + [proof_tac axioms p;exact_check endt] gls + +let convert_to_hyp_tac axioms id1 t1 id2 t2 p gls = + let tt2=make_term t2 in + let h=pf_get_new_id (id_of_string "H") gls in + let false_t=mkApp (mkVar id2,[|mkVar h|]) in + tclTHENS (true_cut (Name h) tt2) + [convert_to_goal_tac axioms id1 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=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, + [|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 -> make_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 additionnal_terms gls= + Coqlib.check_required_library ["Coq";"Init";"Logic"]; + let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in + let state = make_prb gls 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.") 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..6082beb6 100644 --- a/contrib/cc/CCSolve.v +++ b/contrib/cc/cctac.mli @@ -6,17 +6,11 @@ (* * 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 7298 2005-08-17 12:56:38Z 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 : constr list -> tactic + +val cc_fail : tactic diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4 new file mode 100644 index 00000000..0bdf7608 --- /dev/null +++ b/contrib/cc/g_congruence.ml4 @@ -0,0 +1,29 @@ +(************************************************************************) +(* 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 7734 2005-12-26 14:06:51Z herbelin $ *) + +open Cctac +open Tactics +open Tacticals + +(* Tactic registration *) + +TACTIC EXTEND cc + [ "congruence" ] -> [ tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic [])) + cc_fail ] +END + +TACTIC EXTEND cc_with + [ "congruence" "with" ne_constr_list(l) ] -> [ tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic l)) + cc_fail] +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..29d8fdcf 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 5920 2004-07-16 20:01:26Z herbelin $ *) open Pp open Util 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..31effc1b 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 5920 2004-07-16 20:01:26Z herbelin $ *) open Util open Names 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..eeec28a5 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 7740 2005-12-26 20:07:21Z 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 *) @@ -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..e5347670 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 7837 2006-01-11 09:47:32Z 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 @@ -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..0eb8806c 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 7837 2006-01-11 09:47:32Z herbelin $ *) open Util open Names @@ -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..1e485180 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 5920 2004-07-16 20:01:26Z herbelin $ *) open Util open Names 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..af684e6e --- /dev/null +++ b/contrib/dp/dp.ml @@ -0,0 +1,760 @@ +(* 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 = + if Sys.command (sprintf "why --simplify %s" fwhy) <> 0 then + anomaly ("call to why --simplify " ^ fwhy ^ " failed; please report"); + 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 + anomaly ("call to " ^ cmd ^ " failed; please report"); + 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 = + if Sys.command (sprintf "why --cvcl %s" fwhy) <> 0 then + anomaly ("call to why --cvcl " ^ fwhy ^ " failed; please report"); + 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 = + if Sys.command (sprintf "why --harvey %s" fwhy) <> 0 then + anomaly ("call to why --harvey " ^ fwhy ^ " failed; please report"); + 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..8d8438dc 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 7651 2005-12-16 03:19:20Z letouzey $ i*) open Pp open Util @@ -143,7 +143,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 +184,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 +239,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 = @@ -285,7 +285,7 @@ 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 @@ -317,7 +317,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 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..c581c620 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 6328 2004-11-18 17:31:41Z sacerdot $ 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,14 +53,23 @@ let environment_until dir_opt = | _ -> assert false in parse (Library.loaded_libraries ()) -type visit = { mutable kn : KNset.t; mutable mp : MPset.t } +type visit = + { mutable kn : KNset.t; mutable ref : Refset.t; mutable mp : MPset.t } let in_kn v kn = KNset.mem kn v.kn +let in_ref v ref = Refset.mem ref v.ref 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) +let visit_ref v r = + let r = + (* if we meet a constructor we must export the inductive definition *) + match r with + ConstructRef (r,_) -> IndRef r + | _ -> r + in + v.ref <- Refset.add r v.ref; visit_mp v (modpath_of_r r) exception Impossible @@ -102,7 +112,7 @@ let get_spec_references v s = let rec extract_msig env v 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 else begin @@ -143,9 +153,9 @@ let rec extract_msb env v 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 vkn = Array.map (fun id -> make_con 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 b = array_exists (fun con -> in_ref v (ConstRef con)) vkn in if all || b then let d = extract_fixpoint env vkn recd in if (not b) && (logical_decl d) then ms @@ -153,8 +163,8 @@ let rec extract_msb env v mp all = function 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 kn = make_con mp empty_dirpath l in + let b = in_ref v (ConstRef kn) in if all || b then let d = extract_constant env kn cb in if (not b) && (logical_decl d) then ms @@ -163,7 +173,7 @@ let rec extract_msb env v mp all = function | (l,SEBmind mib) :: msb -> 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 b = in_ref v (IndRef (kn,0)) in (* 0 is dummy *) if all || b then let d = Dind (kn, extract_inductive env kn) in if (not b) && (logical_decl d) then ms @@ -217,12 +227,12 @@ 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_ref r = Refset.add r in + let refs = List.fold_right add_ref refs Refset.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 } + let mps = Refset.fold (fun k -> add_mp (modpath_of_r k)) refs mps in + { kn = KNset.empty; ref = refs; mp = mps } in let env = Global.env () in List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) @@ -270,10 +280,9 @@ let extraction qid = else begin let prm = { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in - let kn = kn_of_r 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; + print_one_decl struc (modpath_of_r r) d; reset_tables () end @@ -315,7 +324,7 @@ let extraction_module m = 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 v={ kn = KNset.empty ; ref = Refset.empty; mp = prefixes_mp mp } in let env = Global.env () in let struc = List.rev_map @@ -350,7 +359,9 @@ let extraction_library is_rec m = | 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 v = + { kn = KNset.empty; ref = Refset.empty; + mp = MPset.singleton (MPfile dir_m) } in let l = environment_until (Some dir_m) in let struc = let env = Global.env () in 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..a4bf973d 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 7639 2005-12-02 10:01:15Z gregoire $ i*) (*i*) open Util @@ -230,7 +230,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 @@ -295,8 +295,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* 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 = @@ -354,22 +354,22 @@ 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 else - let knp = make_kn mp d (label_of_id id) in + let knp = make_con 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; + 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 @@ -384,8 +384,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let n = nb_default_params env mip0.mind_nf_arity 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_structure ip).s_PROJ with Not_found -> () end; Record field_glob @@ -419,7 +419,7 @@ 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 @@ -448,7 +448,7 @@ let type_expunge env = type_expunge (mlt_env env) 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 @@ -515,7 +515,7 @@ 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] *) @@ -678,7 +678,6 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = 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. *) 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..c4ed364a 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 7653 2005-12-16 04:12:26Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -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 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..cf722e4e 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 6064 2004-09-06 07:49:51Z letouzey $ i*) (*s Target language for extraction: a core ML called MiniML. *) diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index c01766b0..facab18e 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 7574 2005-11-17 15:48:45Z letouzey $ i*) (*i*) open Pp @@ -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) @@ -252,16 +252,17 @@ type abbrev_map = global_reference -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) + let type_expand env t = let rec expand = function - | Tmeta _ -> 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 +270,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 -> @@ -290,7 +291,7 @@ let type_neq env t t' = (type_expand env t <> type_expand env t') let type_to_sign env t = let rec f = function - | Tmeta _ -> assert false + | Tmeta {contents = Some t} -> f t | Tarr (a,b) -> (Tdummy <> a) :: (f b) | _ -> [] in f (type_expand env t) @@ -304,7 +305,7 @@ let type_expunge env t = let rec f t s = if List.mem false 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 @@ -377,7 +378,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. *) @@ -594,11 +595,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 +655,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; @@ -1117,7 +1119,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..1ba1df64 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 6303 2004-11-16 12:37:40Z sacerdot $ i*) open Util open Names @@ -101,7 +101,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..ff8daf46 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 7632 2005-12-01 14:35:21Z 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 | _ -> () @@ -307,8 +316,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,16 +344,16 @@ 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) @@ -356,7 +364,7 @@ let rec optim prm s = function | 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 +378,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 +396,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 +415,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..f5208c0d 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 7632 2005-12-01 14:35:21Z letouzey $ i*) open Names open Declarations open Environ open Libnames open Miniml +open Mod_subst (*s Functions upon modules missing in [Modops]. *) diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index ff9cfd21..a0620d72 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 7632 2005-12-01 14:35:21Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -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 @@ -409,7 +408,7 @@ let pp_one_ind prefix ip pl cv = (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 *)" + 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)) @@ -480,13 +479,13 @@ let pp_mind 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 -> 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..bd4fe924 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 6555 2005-01-03 19:25:36Z sacerdot $ 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 @@ -207,6 +221,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 +337,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); 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/field/Field.v b/contrib/field/Field.v index 7b48e275..3cc097fc 100644 --- a/contrib/field/Field.v +++ b/contrib/field/Field.v @@ -6,7 +6,7 @@ (* * 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: Field.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Field_Compl. Require Export Field_Theory. diff --git a/contrib/field/Field_Compl.v b/contrib/field/Field_Compl.v index cba921f7..774b3084 100644 --- a/contrib/field/Field_Compl.v +++ b/contrib/field/Field_Compl.v @@ -6,7 +6,7 @@ (* * 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: Field_Compl.v 5920 2004-07-16 20:01:26Z herbelin $ *) Inductive listT (A:Type) : Type := | nilT : listT A diff --git a/contrib/field/Field_Tactic.v b/contrib/field/Field_Tactic.v index c5c06547..afa0a814 100644 --- a/contrib/field/Field_Tactic.v +++ b/contrib/field/Field_Tactic.v @@ -6,7 +6,7 @@ (* * 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: Field_Tactic.v 8134 2006-03-05 16:39:17Z herbelin $ *) Require Import Ring. Require Export Field_Compl. @@ -14,6 +14,10 @@ Require Export Field_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 @@ -24,49 +28,46 @@ Ltac mem_assoc var lvar := 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 + | (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 + 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:(consT AT X1 lvar) + end + end in + let AT := get_component A FT in + let lvar := seek_var (nilT AT) trm in + number lvar. Ltac assoc elt lst := match constr:lst with @@ -79,13 +80,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 @@ -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) + | |- (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 := eval cbv beta iota delta [Aone X1] in (Aone X1) - with AmultT := eval cbv beta iota delta [Amult X1] in (Amult X1) in + 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,27 +253,27 @@ Ltac apply_simplif sfun := end. Ltac unfolds FT := - match eval cbv beta iota delta [Aminus] in (Aminus FT) with + match get_component Aminus FT with | (Field_Some _ ?X1) => unfold X1 in |- * | _ => idtac end; - match eval cbv beta iota delta [Adiv] in (Adiv FT) with + match get_component Adiv FT with | (Field_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 @@ -303,11 +303,11 @@ 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 + (match get_component Aminus FT with | (Field_Some _ ?X1) => eval cbv beta delta [X1] in trm | _ => trm end) in - match eval cbv beta iota delta [Adiv] in (Adiv FT) with + match get_component Adiv FT with | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e | _ => e end. @@ -429,4 +429,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; [ ring trep | field_gen FT ]). diff --git a/contrib/field/Field_Theory.v b/contrib/field/Field_Theory.v index 8737fd79..2c954652 100644 --- a/contrib/field/Field_Theory.v +++ b/contrib/field/Field_Theory.v @@ -6,7 +6,7 @@ (* * 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: Field_Theory.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Import Peano_dec. Require Import Ring. diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index 32adec66..35591f23 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 7837 2006-01-11 09:47:32Z herbelin $ *) open Names open Pp @@ -21,6 +21,7 @@ open Util open Vernacinterp open Vernacexpr open Tacexpr +open Mod_subst (* Interpretation of constr's *) let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c @@ -43,7 +44,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 @@ -113,8 +114,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 ++ @@ -149,8 +150,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";"Field"]; 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 +172,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";"Field"]; let env = (pf_env g) and evc = (project g) in let th = valueIn (VConstr (guess_theory env evc l)) @@ -184,7 +184,7 @@ let field_term l g = (* Declaration of Field *) -TACTIC EXTEND Field -| [ "Field" ] -> [ field ] -| [ "Field" ne_constr_list(l) ] -> [ field_term l ] +TACTIC EXTEND field +| [ "field" ] -> [ field ] +| [ "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..fde48d2b 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 7493 2005-11-02 22:12:16Z mohring $ *) open Hipattern open Names @@ -47,14 +47,14 @@ let rec nb_prod_after n c= 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 +99,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..0970d5db 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 7909 2006-01-21 11:09:18Z herbelin $ *) open Formula open Sequent @@ -41,7 +41,7 @@ let _= 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 +81,16 @@ 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) ] -> +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) ] -> +| [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> [ gen_ground_tac true (option_app eval_tactic t) (Bases l) ] -| [ "Firstorder" tactic_opt(t) ] -> +| [ "firstorder" tactic_opt(t) ] -> [ gen_ground_tac true (option_app eval_tactic t) Void ] END -(* Obsolete since V8.0 -TACTIC EXTEND GTauto - [ "GTauto" ] -> - [ gen_ground_tac false (Some fail_solver) Void ] -END -*) - -TACTIC EXTEND GIntuition - [ "GIntuition" tactic_opt(t) ] -> +TACTIC EXTEND gintuition + [ "gintuition" tactic_opt(t) ] -> [ gen_ground_tac false (option_app eval_tactic t) Void ] END diff --git a/contrib/first-order/ground.ml b/contrib/first-order/ground.ml index 23e27a3c..bb096308 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 7909 2006-01-21 11:09:18Z herbelin $ *) 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,7 +78,7 @@ 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) @@ -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..f6653b82 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 7909 2006-01-21 11:09:18Z 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; @@ -211,4 +213,4 @@ let normalize_evaluables= None->unfold_in_concl (Lazy.force defined_connectives) | 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..8836b76e 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 5920 2004-07-16 20:01:26Z herbelin $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) 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/indfun.ml b/contrib/funind/indfun.ml new file mode 100644 index 00000000..2fcdd3a7 --- /dev/null +++ b/contrib/funind/indfun.ml @@ -0,0 +1,468 @@ +open Util +open Names +open Term + +open Pp +open Indfun_common +open Libnames +open Rawterm +open Declarations + +type annot = + Struct of identifier + | Wf of Topconstr.constr_expr * identifier option + | Mes of Topconstr.constr_expr * identifier option + + +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 + +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 + + +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,"GenFixpoint", + 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) + + + +let rec is_rec names = + let names = List.fold_right Idset.add names Idset.empty in + let check_id id = Idset.mem id names in + let rec lookup = function + | RVar(_,id) -> check_id id + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false + | RCast(_,b,_,_) -> lookup b + | RRec _ -> assert false + | RIf _ -> failwith "Rif not implemented" + | RLetIn(_,_,t,b) | RLambda(_,_,t,b) | RProd(_,_,t,b) | RLetTuple(_,_,_,t,b) -> + lookup t || lookup b + | RApp(_,f,args) -> List.exists lookup (f::args) + | RCases(_,_,el,brl) -> + List.exists (fun (e,_) -> lookup e) el || + List.exists (fun (_,_,_,ret)-> lookup ret) brl + in + lookup + +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 generate_principle + do_built fix_rec_l recdefs interactive_proof parametrize + (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) = + 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 parametrize names funs_args funs_types recdefs; + if do_built + then + begin + 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 _ = + Util.list_map_i + (fun i x -> + let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in + let princ_type = + (Global.lookup_constant princ).Declarations.const_type + in + New_arg_principle.generate_functional_principle + interactive_proof + princ_type + None + None + funs_kn + i + (continue_proof 0 [|funs_kn.(i)|]) + ) + 0 + fix_rec_l + in + () + end + with e -> + Pp.msg_warning (Cerrors.explain_exn e) + + +let register_struct is_rec fixpoint_exprl = + match fixpoint_exprl with + | [(fname,_,bl,ret_type,body),_] when not is_rec -> + Command.declare_definition + fname + (Decl_kinds.Global,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 tcc_lemma_ref + is_mes f_ref eq_ref rec_arg_num rec_arg_type nb_args relation + (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + Recdef.prove_principle tcc_lemma_ref + is_mes f_ref eq_ref rec_arg_num rec_arg_type nb_args relation + + +let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg 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 -> + Util.list_index (Name wf_arg) names + in + let unbounded_eq = + let f_app_args = + Topconstr.CApp + (dummy_loc, + (None,Topconstr.mkIdentC fname) , + (List.map + (function + | _,Anonymous -> assert false + | _,Name e -> (Topconstr.mkIdentC e,None) + ) + (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 tcc_lemma_ref f_ref eq_ref rec_arg_num rec_arg_type nb_args relation = + try + pre_hook + (generate_correction_proof_wf tcc_lemma_ref is_mes + f_ref eq_ref rec_arg_num rec_arg_type nb_args relation + ); + Command.save_named true + with e -> + (* No proof done *) + () + in + Recdef.recursive_definition + is_mes fname + type_of_f + wf_rel_expr + rec_arg_num + eq + hook + + +let register_mes fname wf_mes_expr wf_arg 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 wf_rel_from_mes (Some wf_arg) args ret_type body + + +let do_generate_principle register_built interactive_proof fixpoint_exprl = + let recdefs = build_newrecursive fixpoint_exprl in + let _is_struct = + match fixpoint_exprl with + | [((name,Some (Wf (wf_rel,wf_x)),args,types,body))] -> + let pre_hook = + generate_principle + register_built + fixpoint_exprl + recdefs + true + false + in + if register_built then register_wf name wf_rel wf_x args types body pre_hook; + false + | [((name,Some (Mes (wf_mes,wf_x)),args,types,body))] -> + let pre_hook = + generate_principle + register_built + fixpoint_exprl + recdefs + true + false + in + if register_built then register_mes name wf_mes wf_x args types body pre_hook; + false + | _ -> + 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 Util.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 + Util.user_err_loc + (Util.dummy_loc,"GenFixpoint", + Pp.str "the recursive argument needs to be specified") + else + (name,(0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation) + | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> + error + ("Cannot use mutual definition with well-founded recursion") + ) + (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 + register_built + fixpoint_exprl + recdefs + interactive_proof + true + (New_arg_principle.prove_princ_for_struct interactive_proof); + true + + in + () + +let make_graph (id:identifier) = + let c_body = + try + let c = const_of_id id in + Global.lookup_constant c + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id) ) + 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 = + 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 = Constrextern.extern_constr false env body in + let res' = Constrextern.extern_type false env c_body.const_type 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,res' + with + | UserError(s,msg) as 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 + | 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 + in + let expr_list = + match extern_body with + | Topconstr.CFix(loc,l_id,fixexprl) -> + let l = + List.map + (fun (id,(n,recexp),bl,t,b) -> + let nal = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_) -> nal + ) + bl + ) + in + let rec_id = + match List.nth nal n with |(_,Name id) -> id | _ -> anomaly "" + in + (id, Some (Struct rec_id),bl,t,b) + ) + fixexprl + in + l + | _ -> + let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = +(* Pp.msgnl (str "body: " ++Ppconstr.pr_lconstr_expr b); *) +(* Pp.msgnl (str "type: " ++ Ppconstr.pr_lconstr_expr t); *) +(* Pp.msgnl (fnl ()); *) + 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 rec chop_n_arrow n t = + if n > 0 + then + match t with + | Topconstr.CArrow(_,_,t) -> chop_n_arrow (n-1) t + | Topconstr.CProdN(_,nal_ta',t') -> + let n' = + List.fold_left + (fun n (nal,t'') -> + n+List.length nal) n nal_ta' + in + assert (n'<= n); + chop_n_arrow (n - n') t' + | _ -> anomaly "Not enough products" + else t + 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 + in + let nal_tas,b,t = get_args extern_body extern_type in + [(id,None,nal_tas,t,b)] + + in + do_generate_principle false false 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..b32dfacb --- /dev/null +++ b/contrib/funind/indfun_common.ml @@ -0,0 +1,319 @@ +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 msgnl m = + () + +let invalid_argument s = raise (Invalid_argument s) + +(* let idtbl = Hashtbl.create 29 *) +(* let reset_name () = Hashtbl.clear idtbl *) + +(* let fresh_id s = *) +(* try *) +(* let id = Hashtbl.find idtbl s in *) +(* incr id; *) +(* id_of_string (s^(string_of_int !id)) *) +(* with Not_found -> *) +(* Hashtbl.add idtbl s (ref (-1)); *) +(* id_of_string s *) + +(* let fresh_name s = Name (fresh_id s) *) +(* let get_name ?(default="H") = function *) +(* | Anonymous -> fresh_name default *) +(* | Name n -> Name n *) + + + +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") + + +(* (\************************************************\) *) +(* (\* Should be removed latter *\) *) +(* (\* Comes from new induction (cf Pierre) *\) *) +(* (\************************************************\) *) + +(* open Sign *) +(* open Term *) + +(* type elim_scheme = *) + +(* (\* { (\\* lists are in reverse order! *\\) *\) *) +(* (\* params: rel_context; (\\* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *\\) *\) *) +(* (\* predicates: rel_context; (\\* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *\\) *\) *) +(* (\* branches: rel_context; (\\* branchr,...,branch1 *\\) *\) *) +(* (\* args: rel_context; (\\* (xni, Ti_ni) ... (x1, Ti_1) *\\) *\) *) +(* (\* indarg: rel_declaration option; (\\* Some (H,I prm1..prmp x1...xni) if present, None otherwise *\\) *\) *) +(* (\* concl: types; (\\* Qi x1...xni HI, some prmis may not be present *\\) *\) *) +(* (\* indarg_in_concl:bool; (\\* true if HI appears at the end of conclusion (dependent scheme) *\\) *\) *) +(* (\* } *\) *) + + + +(* let occur_rel n c = *) +(* let res = not (noccurn n c) in *) +(* res *) + +(* let list_filter_firsts f l = *) +(* let rec list_filter_firsts_aux f acc l = *) +(* match l with *) +(* | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l' *) +(* | _ -> acc,l *) +(* in *) +(* list_filter_firsts_aux f [] l *) + +(* let count_rels_from n c = *) +(* let rels = Termops.free_rels c in *) +(* let cpt,rg = ref 0, ref n in *) +(* while Util.Intset.mem !rg rels do *) +(* cpt:= !cpt+1; rg:= !rg+1; *) +(* done; *) +(* !cpt *) + +(* let count_nonfree_rels_from n c = *) +(* let rels = Termops.free_rels c in *) +(* if Util.Intset.exists (fun x -> x >= n) rels then *) +(* let cpt,rg = ref 0, ref n in *) +(* while not (Util.Intset.mem !rg rels) do *) +(* cpt:= !cpt+1; rg:= !rg+1; *) +(* done; *) +(* !cpt *) +(* else raise Not_found *) + +(* (\* cuts a list in two parts, first of size n. Size must be greater than n *\) *) +(* let cut_list n l = *) +(* let rec cut_list_aux acc n l = *) +(* if n<=0 then acc,l *) +(* else match l with *) +(* | [] -> assert false *) +(* | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in *) +(* let res = cut_list_aux [] n l in *) +(* res *) + +(* let exchange_hd_prod subst_hd t = *) +(* let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) *) + +(* let compute_elim_sig elimt = *) +(* (\* conclusion is the final (Qi ...) *\) *) +(* let hyps,conclusion = decompose_prod_assum elimt in *) +(* (\* ccl is conclusion where Qi (that is rel <something>) is replaced *) +(* by a constant (Prop) to avoid it being counted as an arg or *) +(* parameter in the following. *\) *) +(* let ccl = exchange_hd_prod mkProp conclusion in *) +(* (\* indarg is the inductive argument if it exists. If it exists it is *) +(* the last hyp before the conclusion, so it is the first element of *) +(* hyps. To know the first elmt is an inductive arg, we check if the *) +(* it appears in the conclusion (as rel 1). If yes, then it is not *) +(* an inductive arg, otherwise it is. There is a pathological case *) +(* with False_inf where Qi is rel 1, so we first get rid of Qi in *) +(* ccl. *\) *) +(* (\* if last arg of ccl is an application then this a functional ind *) +(* principle *\) let last_arg_ccl = *) +(* try List.hd (List.rev (snd (decompose_app ccl))) *) +(* with Failure "hd" -> mkProp in (\* dummy constr that is not an app *) +(* *\) let hyps',indarg,dep = *) +(* if isApp last_arg_ccl *) +(* then *) +(* hyps,None , false (\* no HI at all *\) *) +(* else *) +(* try *) +(* if noccurn 1 ccl (\* rel 1 does not occur in ccl *\) *) +(* then *) +(* List.tl hyps , Some (List.hd hyps), false (\* it does not *) +(* occur in concl *\) else *) +(* List.tl hyps , Some (List.hd hyps) , true (\* it does occur in concl *\) *) +(* with Failure s -> Util.error "cannot recognise an induction schema" *) +(* in *) + +(* (\* Arguments [xni...x1] must appear in the conclusion, so we count *) +(* successive rels appearing in conclusion **Qi is not considered a *) +(* rel** *\) let nargs = count_rels_from *) +(* (match indarg with *) +(* | None -> 1 *) +(* | Some _ -> 2) ccl in *) +(* let args,hyps'' = cut_list nargs hyps' in *) +(* let rel_is_pred (_,_,c) = isSort (snd(decompose_prod_assum c)) in *) +(* let branches,hyps''' = *) +(* list_filter_firsts (function x -> not (rel_is_pred x)) hyps'' *) +(* in *) +(* (\* Now we want to know which hyps remaining are predicates and which *) +(* are parameters *\) *) +(* (\* We rebuild *) + +(* forall (x1:Ti_1) (xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY *) +(* x1...xni HI ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^ *) +(* optional *) +(* opt *) + +(* Free rels appearing in this term are parameters. We catch all of *) +(* them if HI is present. In this case the number of parameters is *) +(* the number of free rels. Otherwise (principle generated by *) +(* functional induction or by hand) WE GUESS that all parameters *) +(* appear in Ti_js, IS THAT TRUE??. *) + +(* TODO: if we want to generalize to the case where arges are merged *) +(* with branches (?) and/or where several predicates are cited in *) +(* the conclusion, we should do something more precise than just *) +(* counting free rels. *) +(* *\) *) +(* let concl_with_indarg = *) +(* match indarg with *) +(* | None -> ccl *) +(* | Some c -> it_mkProd_or_LetIn ccl [c] in *) +(* let concl_with_args = it_mkProd_or_LetIn concl_with_indarg args in *) +(* (\* let nparams2 = Util.Intset.cardinal (Termops.free_rels concl_with_args) in *\) *) +(* let nparams = *) +(* try List.length (hyps'''@branches) - count_nonfree_rels_from 1 *) +(* concl_with_args with Not_found -> 0 in *) +(* let preds,params = cut_list (List.length hyps''' - nparams) hyps''' in *) +(* let elimscheme = { *) +(* params = params; *) +(* predicates = preds; *) +(* branches = branches; *) +(* args = args; *) +(* indarg = indarg; *) +(* concl = conclusion; *) +(* indarg_in_concl = dep; *) +(* } *) +(* in *) +(* elimscheme *) + +(* let get_params elimt = *) +(* (compute_elim_sig elimt).params *) +(* (\************************************************\) *) +(* (\* end of Should be removed latter *\) *) +(* (\* Comes from new induction (cf Pierre) *\) *) +(* (\************************************************\) *) + diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli new file mode 100644 index 00000000..ab5195b0 --- /dev/null +++ b/contrib/funind/indfun_common.mli @@ -0,0 +1,41 @@ +open Names +open Pp + +val mk_rel_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 + + diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 new file mode 100644 index 00000000..7b3d8cbd --- /dev/null +++ b/contrib/funind/indfun_main.ml4 @@ -0,0 +1,201 @@ +(************************************************************************) +(* 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 + +TACTIC EXTEND newfuninv + [ "functional" "inversion" ident(hyp) ident(fname) ] -> + [ + Invfun.invfun hyp fname + ] +END + + +let pr_fun_ind_using prc _ _ opt_c = + match opt_c with + | None -> mt () + | Some c -> spc () ++ hov 2 (str "using" ++ spc () ++ prc c) + +ARGUMENT EXTEND fun_ind_using + TYPED AS constr_opt + PRINTED BY pr_fun_ind_using +| [ "using" constr(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + +let pr_intro_as_pat prc _ _ pat = + str "as" ++ spc () ++ pr_intro_pattern pat + + + + + +ARGUMENT EXTEND with_names TYPED AS intro_pattern PRINTED BY pr_intro_as_pat +| [ "as" simple_intropattern(ipat) ] -> [ ipat ] +| [] ->[ IntroAnonymous ] +END + + +let is_rec 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 scheme_info + then Tactics.new_induct + else + Tactics.new_destruct + + +TACTIC EXTEND newfunind + ["new" "functional" "induction" constr(c) fun_ind_using(princl) with_names(pat)] -> + [ + let f,args = decompose_app c in + fun g -> + let princ = + match princl with + | None -> (* No principle is given let's find the good one *) + let fname = + match kind_of_term f with + | Const c' -> + id_of_label (con_label c') + | _ -> Util.error "Must be used with a function" + in + let princ_name = + ( + Indrec.make_elimination_ident + fname + (Tacticals.elimination_sort_of_goal g) + ) + in + mkConst(const_of_id princ_name ) + | Some princ -> princ + in + let princ_type = 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,Rawterm.NoBindings) in + choose_dest_or_ind + princ_infos + args_as_induction_constr + princ' + pat g + ] +END + + +VERNAC ARGUMENT EXTEND rec_annotation2 + [ "{" "struct" ident(id) "}"] -> [ Struct id ] +| [ "{" "wf" constr(r) ident_opt(id) "}" ] -> [ Wf(r,id) ] +| [ "{" "mes" constr(r) ident_opt(id) "}" ] -> [ Mes(r,id) ] +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,"GenFixpoint", + 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,"GenFixpoint", + 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 GenFixpoint + ["GenFixpoint" rec_definitions2(recsl)] -> + [ do_generate_principle false recsl] +END + +VERNAC COMMAND EXTEND IGenFixpoint + ["IGenFixpoint" rec_definitions2(recsl)] -> + [ do_generate_principle true recsl] +END + + +VERNAC ARGUMENT EXTEND fun_scheme_arg +| [ ident(princ_name) ":=" "Induction" "for" ident(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 + ["New" "Functional" "Scheme" fun_scheme_args(fas) ] -> + [ + New_arg_principle.make_scheme fas + ] +END + + +VERNAC COMMAND EXTEND NewFunctionalCase + ["New" "Functional" "Case" fun_scheme_arg(fas) ] -> + [ + New_arg_principle.make_case_scheme fas + ] +END + + +VERNAC COMMAND EXTEND GenerateGraph +["Generate" "graph" "for" ident(c)] -> [ make_graph c ] +END diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml new file mode 100644 index 00000000..1f711297 --- /dev/null +++ b/contrib/funind/invfun.ml @@ -0,0 +1,148 @@ +open Util +open Names +open Term +open Tacinvutils +open Pp +open Libnames +open Tacticals +open Tactics +open Indfun_common +open Tacmach +open Sign + + +let tac_pattern l = + (Hiddentac.h_reduce + (Rawterm.Pattern l) + Tacticals.onConcl + ) + + +let rec nb_prod x = + let rec count n c = + match kind_of_term c with + Prod(_,_,t) -> count (n+1) t + | LetIn(_,a,_,t) -> count n (subst1 a t) + | Cast(c,_,_) -> count n c + | _ -> n + in count 0 x + +let intro_discr_until n tac : tactic = + let rec intro_discr_until acc : tactic = + fun g -> + if nb_prod (pf_concl g) <= n then tac (List.rev acc) g + else + tclTHEN + intro + (fun g' -> + let id,_,t = pf_last_hyp g' in + tclORELSE + (tclABSTRACT None (Extratactics.h_discrHyp (Rawterm.NamedHyp id))) + (intro_discr_until ((id,t)::acc)) + g' + ) + g + in + intro_discr_until [] + + +let rec discr_rew_in_H hypname idl : tactic = + match idl with + | [] -> (Extratactics.h_discrHyp (Rawterm.NamedHyp hypname)) + | ((id,t)::idl') -> + match kind_of_term t with + | App(eq',[| _ ; arg1 ; _ |]) when eq_constr eq' (Lazy.force eq) -> + begin + let constr,_ = decompose_app arg1 in + if isConstruct constr + then + (discr_rew_in_H hypname idl') + else + tclTHEN + (tclTRY (Equality.general_rewrite_in true hypname (mkVar id))) + (discr_rew_in_H hypname idl') + end + | _ -> discr_rew_in_H hypname idl' + +let finalize fname hypname idl : tactic = + tclTRY ( + (tclTHEN + (Hiddentac.h_reduce + (Rawterm.Unfold [[],EvalConstRef fname]) + (Tacticals.onHyp hypname) + ) + (discr_rew_in_H hypname idl) + )) + +let gen_fargs fargs : tactic = + fun g -> + generalize + (List.map + (fun arg -> + let targ = pf_type_of g arg in + let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in + refl_arg + ) + (Array.to_list fargs) + ) + g + + +let invfun (hypname:identifier) (fid:identifier) : tactic= + fun g -> + let nprod_goal = nb_prod (pf_concl g) in + let f_ind_id = + ( + Indrec.make_elimination_ident + fid + (Tacticals.elimination_sort_of_goal g) + ) + in + let fname = const_of_id fid in + let princ = const_of_id f_ind_id in + let princ_info = + let princ_type = + (try (match (Global.lookup_constant princ) with + {Declarations.const_type=t} -> t + ) + with _ -> assert false) + in + Tactics.compute_elim_sig princ_type + in + let _,_,typhyp = List.find (fun (id,_,_) -> hypname=id) (pf_hyps g) in + let do_invert fargs appf : tactic = + let frealargs = (snd (array_chop (List.length princ_info.params) fargs)) + in + let pat_args = + (List.map (fun e -> ([-1],e)) (Array.to_list frealargs)) @ [[],appf] + in + tclTHENSEQ + [ + gen_fargs frealargs; + tac_pattern pat_args; + Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings); + intro_discr_until nprod_goal (finalize fname hypname) + + ] + in + match kind_of_term typhyp with + | App(eq',[| _ ; arg1 ; arg2 |]) when eq_constr eq' (Lazy.force eq) -> +(* let valf = def_of_const (mkConst fname) in *) + let eq_arg1 , eq_arg2 , good_eq_form , fargs = + match kind_of_term arg1 , kind_of_term arg2 with + | App(f, args),_ when eq_constr f (mkConst fname) -> + arg1 , arg2 , tclIDTAC , args + | _,App(f, args) when eq_constr f (mkConst fname) -> + arg2 , arg1 , symmetry_in hypname , args + | _ , _ -> error "inversion impossible" + in + tclTHEN + good_eq_form + (do_invert fargs eq_arg1) + g + | App(f',fargs) when eq_constr f' (mkConst fname) -> + do_invert fargs typhyp g + + + | _ -> error "inversion impossible" + diff --git a/contrib/funind/new_arg_principle.ml b/contrib/funind/new_arg_principle.ml new file mode 100644 index 00000000..8ef23c48 --- /dev/null +++ b/contrib/funind/new_arg_principle.ml @@ -0,0 +1,1770 @@ +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 + + +let msgnl = Pp.msgnl + +let do_observe () = + Tacinterp.get_debug () <> Tactic_debug.DebugOff + + +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 "++str 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 s tac g + else 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 static_fix_info = + { + idx : int; + name : identifier; + types : types + } + +type static_infos = + { + fixes_ids : identifier list; + ptes_to_fixes : static_fix_info Idmap.t + } + +type 'a dynamic_info = + { + nb_rec_hyps : int; + rec_hyps : identifier list ; + eq_hyps : identifier list; + info : 'a + } + +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 hyp_id t tac = + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENLIST + [ + forward (Some tac) (Genarg.IntroIdentifier prov_id) t; + thin [hyp_id]; + 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_betaoiotazeta = Reductionops.local_strong Reductionops.whd_betaiotazeta + +let remove_useless_rel env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 = + let rel_num = destRel t2 in + + let nb_kept = List.length context - rel_num + and nb_popped = rel_num - 1 + in + + (* We remove the equation *) + let new_end_of_type = pop end_of_type in + + let lt_relnum,ge_relnum = + list_chop + ~msg:("removing useless variable "^(string_of_int rel_num)^" :") + nb_popped + context + in + (* we rebuilt the type of hypothesis after the rel to remove *) + let hyp_type_lt_relnum = + it_mkProd_or_LetIn ~init:new_end_of_type lt_relnum + in + (* we replace Rel 1 by t1 *) + let new_hyp_type_lt_relnum = subst1 t1 hyp_type_lt_relnum in + (* we resplit the type of hyp_type *) + let new_lt_relnum,new_end_of_type = + Sign.decompose_prod_n_assum nb_popped new_hyp_type_lt_relnum + in + (* and rebuilt new context of hyp *) + let new_context = new_lt_relnum@(List.tl ge_relnum) in + let new_typ_of_hyp = + nf_betaoiotazeta (it_mkProd_or_LetIn ~init:new_end_of_type new_context) + in + let prove_simpl_eq = + tclTHENLIST + [ + tclDO (nb_popped + nb_kept) intro; + (fun g' -> + let new_hyps_ids = pf_ids_of_hyps g' in + let popped_ids,others = + list_chop ~msg:"removing useless variable pop :" + nb_popped new_hyps_ids in + let kept_ids,_ = + list_chop ~msg: " removing useless variable kept : " + nb_kept others + in + let rev_to_apply = + (mkApp(Lazy.force refl_equal,[|Typing.type_of env sigma t1;t1|])):: + ((List.map mkVar popped_ids)@ + (t1:: + (List.map mkVar kept_ids))) + in + let to_refine = applist(mkVar hyp_id,List.rev rev_to_apply) in + refine to_refine g' + ) + ] + in + let simpl_eq_tac = change_hyp_with_using hyp_id new_typ_of_hyp + (observe_tac "prove_simpl_eq" prove_simpl_eq) + in + let new_end_of_type = nf_betaoiotazeta new_end_of_type in + (new_context,new_end_of_type,simpl_eq_tac),new_typ_of_hyp, + (str " removing useless variable " ++ str (string_of_int rel_num) ) + + +let decompose_eq env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 = + let c1,args1 = destApp t1 + and c2,args2 = destApp t2 + in + (* This tactic must be used after is_incompatible_eq *) + assert (eq_constr c1 c2); + (* we remove this equation *) + let new_end_of_type = pop end_of_type in + let new_eqs = + array_map2_i + (fun i arg1 arg2 -> + let new_eq = + let type_of_arg = Typing.type_of env sigma arg1 in + mkApp(Lazy.force eq,[|type_of_arg;arg1;arg2|]) + in + Anonymous,None,lift i new_eq + ) + args1 + args2 + in + let nb_new_eqs = Array.length new_eqs in + (* we add the new equation *) + let new_end_of_type = lift nb_new_eqs new_end_of_type in + let local_context = + List.rev (Array.to_list new_eqs) in + let new_end_of_type = it_mkProd_or_LetIn ~init:new_end_of_type local_context in + let new_typ_of_hyp = + nf_betaoiotazeta (it_mkProd_or_LetIn ~init:new_end_of_type context) + in + let prove_pattern_simplification = + let context_length = List.length context in + tclTHENLIST + [ + tclDO (context_length + nb_new_eqs) intro ; + (fun g -> + let new_eqs,others = + list_chop ~msg:"simplifying pattern : new_eqs" nb_new_eqs (pf_hyps g) + in + let context_hyps,_ = list_chop ~msg:"simplifying pattern : context_hyps" + context_length others in + let eq_args = + List.rev_map + (fun (_,_, eq) -> let _,args = destApp eq in args.(1),args.(2)) + new_eqs + in + let lhs_args,rhs_args = List.split eq_args in + let lhs_eq = applist(c1,lhs_args) + and rhs_eq = applist(c1,rhs_args) + in + let type_of_eq = pf_type_of g lhs_eq in + let eq_to_assert = + mkApp(Lazy.force eq,[|type_of_eq;lhs_eq;rhs_eq|]) + in + let prove_new_eq = + tclTHENLIST [ + tclMAP + (fun (id,_,_) -> + (* The tclTRY here is used when trying to rewrite + on Set + eg (@cons A x l)=(@cons A x' l') generates 3 eqs + A=A -> x=x' -> l = l' ... + + *) + tclTRY (Equality.rewriteLR (mkVar id)) + ) + new_eqs; + reflexivity + ] + in + let new_eq_id = pf_get_new_id (id_of_string "H") g in + let create_new_eq = + forward + (Some (observe_tac "prove_new_eq" (prove_new_eq))) + (Genarg.IntroIdentifier new_eq_id) + eq_to_assert + in + let to_refine = + applist ( + mkVar hyp_id, + List.rev ((mkVar new_eq_id):: + (List.map (fun (id,_,_) -> mkVar id) context_hyps))) + in + tclTHEN + (observe_tac "create_new_eq" create_new_eq ) + (observe_tac "refine in decompose_eq " (refine to_refine)) + g + ) + ] + in + let simpl_eq_tac = + change_hyp_with_using hyp_id new_typ_of_hyp (observe_tac "prove_pattern_simplification " prove_pattern_simplification) + in + (context,nf_betaoiotazeta new_end_of_type,simpl_eq_tac),new_typ_of_hyp, + str "simplifying an equation " + +let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = + if not (noccurn 1 end_of_type) + then (* if end_of_type depends on this term we don't touch it *) + begin + observe (str "Not treating " ++ pr_lconstr t ); + failwith "NoChange"; + end; + let res,new_typ_of_hyp,msg = + if not (isApp t) then failwith "NoChange"; + let f,args = destApp t in + if not (eq_constr f (Lazy.force eq)) then failwith "NoChange"; + let t1 = args.(1) + and t2 = args.(2) + in + if isRel t2 && closed0 t1 then (* closed_term = x with x bound in context *) + begin + remove_useless_rel env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 + end + else if isAppConstruct t1 && isAppConstruct t2 (* C .... = C .... *) + then decompose_eq env sigma hyp_id context t end_of_type t1 t2 + else failwith "NoChange" + in + observe (str "In " ++ Ppconstr.pr_id hyp_id ++ + msg ++ 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_typ_of_hyp ++ fnl ()); + (res:'a*'b*'c) + + + + +let is_property static_info t_x = + if isApp t_x + then + let pte,args = destApp t_x in + if isVar pte && array_for_all closed0 args + then Idmap.mem (destVar pte) static_info.ptes_to_fixes + 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 : tactic = + let constr_eq = Lazy.force eq in + let replace_if_unify arg (pat,cl,id,lhs) : tactic = + fun g -> + try + let (evd,matched) = + Unification.w_unify_to_subterm + (pf_env g) ~mod_delta:false (pat,arg) cl.Clenv.env + in + let cl' = {cl with Clenv.env = evd } in + let c2 = Clenv.clenv_nf_meta cl' lhs in + (Equality.replace matched c2) g + with _ -> tclFAIL 0 (str "") g + in + let rewrite_on_step equalities : tactic = + fun g -> + match kind_of_term (pf_concl g) with + | App(_,args) when (not (test_var args arg_num)) -> +(* tclFIRST (List.map (fun a -> observe_tac (str "replace_if_unify") (replace_if_unify args.(arg_num) a)) equalities) g *) + tclFIRST (List.map (replace_if_unify args.(arg_num)) equalities) g + | _ -> + raise (Util.UserError("", (str "No more rewrite" ++ + pr_lconstr_env (pf_env g) (pf_concl g)))) + in + fun g -> + let equalities = + List.filter + ( + fun (_,_,id_t) -> + match kind_of_term id_t with + | App(f,_) -> eq_constr f constr_eq + | _ -> false + ) + (pf_hyps g) + in + let f (id,_,ctype) = + let c = mkVar id in + let eqclause = Clenv.make_clenv_binding g (c,ctype) Rawterm.NoBindings in + let clause_type = Clenv.clenv_type eqclause in + let f,args = decompose_app (clause_type) in + let rec split_last_two = function + | [c1;c2] -> (c1, c2) + | x::y::z -> + split_last_two (y::z) + | _ -> + error ("The term provided is not an equivalence") + in + let (c1,c2) = split_last_two args in + (c2,eqclause,id,c1) + in + let matching_hyps = List.map f equalities in + tclTRY (tclREPEAT (tclPROGRESS (rewrite_on_step matching_hyps))) g + +*) + + +let rewrite_until_var arg_num eq_ids : tactic = + let test_var g = + let _,args = destApp (pf_concl g) in + isVar 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 prove_rec_hyp eq_hyps fix_info = + tclTHEN + (rewrite_until_var (fix_info.idx - 1) 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 rec_pte_id = id_of_string "Hrec" +let clean_hyp_with_heq static_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_betaoiotazeta 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 + if is_property static_infos t_x then + begin + let pte,pte_args = (destApp t_x) in + let fix_info = Idmap.find (destVar pte) static_infos.ptes_to_fixes 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 + tclTHENLIST + [ + forward + (Some (prove_rec_hyp eq_hyps fix_info)) + (Genarg.IntroIdentifier rec_pte_id) + t_x; + refine to_refine + ] + g + ) + ] + in + tclTHENLIST + [ + observe_tac "hyp rec" + (change_hyp_with_using 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 + let _ = + observe (str "In "++Ppconstr.pr_id hyp_id++ + str " removing useless precond True" + ) + in + 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 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 + 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 static_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 static_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 ; + (continue_tac new_infos) + ] + g + +let heq_id = id_of_string "Heq" + +let treat_new_case static_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 (pr_gls g' ++ fnl () ++ str "last hyp is" ++ + pr_lconstr_env (pf_env g') new_term_value_eq + ); + assert false + 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 static_infos continue_tac new_infos g' + ) + ] + g + +let do_prove_princ_for_struct + (interactive_proof:bool) + (fnames:constant list) + static_infos +(* (ptes:identifier list) *) +(* (fixes:(int*constr*identifier*constr) Idmap.t) *) +(* (hyps: identifier list) *) +(* (term:constr) *) + dyn_infos + : tactic = +(* let fixes_ids = Idmap.fold (fun _ (_,_,id,_) acc -> id::acc) fixes [] in *) + let rec do_prove_princ_for_struct_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 + static_infos + nb_instanciate_partial + (do_prove_princ_for_struct 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 + do_prove_princ_for_struct do_finalize new_infos g' + ) g + | _ -> + do_finalize dyn_infos g + end + | Cast(t,_,_) -> + do_prove_princ_for_struct 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 + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in + do_prove_princ_for_struct_args do_finalize new_infos g + | Const c when not (List.mem c fnames) -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in + do_prove_princ_for_struct_args do_finalize new_infos g + | Const _ -> + do_finalize dyn_infos g + | _ -> +(* observe *) +(* (str "Applied binders not yet implemented: in "++ fnl () ++ *) +(* pr_lconstr_env (pf_env g) term ++ fnl () ++ *) +(* pr_lconstr_env (pf_env g) f ++ spc () ++ str "is applied") ; *) + tclFAIL 0 (str "TODO : Applied binders not yet implemented") g + end + | Fix _ | CoFix _ -> + error ( "Anonymous local (co)fixpoints are not handled yet") + + | Prod _ -> assert false + | LetIn _ -> + let new_infos = + { dyn_infos with + info = nf_betaoiotazeta 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; + do_prove_princ_for_struct do_finalize new_infos + ] g + | _ -> + errorlabstrm "" (str "in do_prove_princ_for_struct found : "(* ++ *) +(* pr_lconstr_env (pf_env g) term *) + ) + and do_prove_princ_for_struct do_finalize dyn_infos g = +(* observe (str "proving with "++Printer.pr_lconstr term++ str " on goal " ++ pr_gls g); *) + do_prove_princ_for_struct_aux do_finalize dyn_infos g + and do_prove_princ_for_struct_args do_finalize dyn_infos (* f_args' args *) :tactic = + fun g -> +(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *) +(* then msgnl (str "do_prove_princ_for_struct_args with " ++ *) +(* pr_lconstr_env (pf_env g) f_args' *) +(* ); *) + let (f_args',args) = dyn_infos.info in + let tac = + match args with + | [] -> + do_finalize {dyn_infos with info = f_args'} + | arg::args -> + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + tclTRYD + (do_prove_princ_for_struct_args + do_finalize + {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} + ) + in + do_prove_princ_for_struct do_finalize + {dyn_infos with info = arg } + in + tclTRYD(tac ) g + in + let do_finish_proof dyn_infos = + clean_goal_with_heq + static_infos + finish_proof dyn_infos + in + observe_tac "do_prove_princ_for_struct" + (do_prove_princ_for_struct do_finish_proof dyn_infos) + +let is_pte_type t = + isSort (snd (decompose_prod t)) + +let is_pte (_,_,t) = is_pte_type t + +exception Not_Rec + + + +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 = + tclORELSE + ( (* we instanciate the hyp if possible *) +(* tclTHENLIST *) +(* [h_generalize [mkApp(mkVar hid,args)]; *) +(* intro_erasing hid] *) + 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 no args then no instanciation ! *) + 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 prove_princ_for_struct interactive_proof fun_num fnames all_funs _naprams : tactic = + fun goal -> +(* observe (str "Proving principle for "++ str (string_of_int fun_num) ++ str "th function : " ++ *) +(* pr_lconstr (mkConst fnames.(fun_num))); *) + let princ_type = pf_concl goal in + let princ_info = compute_elim_sig princ_type 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 params : identifier list ref = ref [] in + let predicates : identifier list ref = ref [] in + let args : identifier list ref = ref [] in + let branches : identifier list ref = ref [] in + let pte_to_fix = ref Idmap.empty in + let fbody_with_params = ref None in + let intro_with_remembrance ref number : tactic = + tclTHEN + ( tclDO number intro ) + (fun g -> + let last_n = list_chop number (pf_hyps g) in + ref := List.map (fun (id,_,_) -> id) (fst last_n)@ !ref; + tclIDTAC g + ) + in + let rec partial_combine body params = + match kind_of_term body,params with + | Lambda (x,t,b),param::params -> + partial_combine (subst1 param b) params + | Fix(infos),_ -> + body,params, Some (infos) + | _ -> body,params,None + in + let build_pte_to_fix (offset:int) params predicates + ((idxs,fix_num),(na,typearray,ca)) (avoid,_) = +(* let true_params,_ = list_chop offset params in *) + let true_params = List.rev params in + let avoid = ref avoid in + let res = list_fold_left_i + (fun i acc pte_id -> + let this_fix_id = fresh_id !avoid "fix___" in + avoid := this_fix_id::!avoid; +(* let this_body = substl (List.rev fnames_as_constr) ca.(i) in *) + let new_type = prod_applist typearray.(i) true_params in + let new_type_args,_ = decompose_prod new_type in + let nargs = List.length new_type_args in + let pte_args = + (* let rev_args = List.rev_map (fun (id,_,_) -> mkVar id) new_type_args in *) + let f = applist((* all_funs *)mkConst fnames.(i),true_params) in + let app_f = mkApp(f,Array.init nargs (fun i -> mkRel(nargs - i))) in + (Array.to_list (Array.init nargs (fun i -> mkRel(nargs - i))))@[app_f] + in + let app_pte = applist(mkVar pte_id,pte_args) in + let new_type = compose_prod new_type_args app_pte in + let fix_info = + { + idx = idxs.(i) - offset + 1; + name = this_fix_id; + types = new_type + } + in + pte_to_fix := Idmap.add pte_id fix_info !pte_to_fix; + fix_info::acc + ) + 0 + [] + predicates + in + !avoid,List.rev res + in + let mk_fixes : tactic = + fun g -> + let body_p,params',fix_infos = + partial_combine fbody (List.rev_map mkVar !params) + in + fbody_with_params := Some body_p; + let offset = List.length params' in + let not_real_param,true_params = + list_chop + ((List.length !params ) - offset) + !params + in + params := true_params; args := not_real_param; +(* observe (str "mk_fixes : params are "++ *) +(* prlist_with_sep spc *) +(* (fun id -> pr_lconstr (mkVar id)) *) +(* !params *) +(* ); *) + let new_avoid,infos = + option_fold_right + (build_pte_to_fix + offset + (List.map mkVar !params) + (List.rev !predicates) + ) + fix_infos + ((pf_ids_of_hyps g),[]) + in + let pre_info,infos = list_chop fun_num infos in + match pre_info,infos with + | [],[] -> tclIDTAC g + | _,this_fix_info::infos' -> + let other_fix_info = + List.map + (fun fix_info -> fix_info.name,fix_info.idx,fix_info.types) + (pre_info@infos') + in + tclORELSE + (h_mutual_fix this_fix_info.name this_fix_info.idx other_fix_info) + (tclFAIL 1000 (str "bad index" ++ + str (string_of_int this_fix_info.idx) ++ + str "offset := " ++ + (str (string_of_int offset)))) + g + | _,[] -> anomaly "Not a valid information" + in + let do_prove ptes_to_fixes args branches : tactic = + fun g -> + let static_infos = + { + ptes_to_fixes = ptes_to_fixes; + fixes_ids = + Idmap.fold + (fun _ fix_info acc -> fix_info.name::acc) + ptes_to_fixes [] + } + in + match kind_of_term (pf_concl g) with + | App(pte,pte_args) when isVar pte -> + begin + let pte = destVar pte in + try + if not (Idmap.mem pte ptes_to_fixes) then raise Not_Rec; + let nparams = List.length !params in + let args_as_constr = List.map mkVar args in + let rec_num,new_body = + let idx' = list_index pte (List.rev !predicates) - 1 in + let f = fnames.(idx') in + let body_with_params = match !fbody_with_params with Some f -> f | _ -> anomaly "" + in + let name_of_f = Name ( id_of_label (con_label f)) in + let ((rec_nums,_),(na,_,bodies)) = destFix body_with_params in + let idx'' = list_index name_of_f (Array.to_list na) - 1 in + let body = substl (List.rev (Array.to_list all_funs)) bodies.(idx'') in + let body = Reductionops.nf_beta (applist(body,(List.rev_map mkVar !params))) in + rec_nums.(idx'') - nparams ,body + in + let applied_body = + Reductionops.nf_beta + (applist(new_body,List.rev args_as_constr)) + in + let do_prove branches applied_body = + do_prove_princ_for_struct + interactive_proof + (Array.to_list fnames) + static_infos + branches + applied_body + in + let replace_and_prove = + tclTHENS + (fun g -> +(* observe (str "replacing " ++ *) +(* pr_lconstr_env (pf_env g) (array_last pte_args) ++ *) +(* str " with " ++ *) +(* pr_lconstr_env (pf_env g) applied_body ++ *) +(* str " rec_arg_num is " ++ str (string_of_int rec_num) *) +(* ); *) + (Equality.replace (array_last pte_args) applied_body) g + ) + [ + clean_goal_with_heq + static_infos do_prove + { + nb_rec_hyps = List.length branches; + rec_hyps = branches; + info = applied_body; + eq_hyps = []; + } ; + try + let id = List.nth (List.rev args_as_constr) (rec_num) in + (* observe (str "choosen var := "++ pr_lconstr id); *) + (tclTHENSEQ + [(h_simplest_case id); + Tactics.intros_reflexivity + ]) + with _ -> tclIDTAC + + ] + in + (observe_tac "doing replacement" ( replace_and_prove)) g + with Not_Rec -> + let fname = destConst (fst (decompose_app (array_last pte_args))) in + tclTHEN + (unfold_in_concl [([],Names.EvalConstRef fname)]) + (observe_tac "" + (fun g' -> + let body = array_last (snd (destApp (pf_concl g'))) in + let dyn_infos = + { nb_rec_hyps = List.length branches; + rec_hyps = branches; + info = body; + eq_hyps = [] + } + in + let do_prove = + do_prove_princ_for_struct + interactive_proof + (Array.to_list fnames) + static_infos + in + clean_goal_with_heq static_infos + do_prove dyn_infos g' + ) + ) + g + end + | _ -> assert false + in + tclTHENSEQ + [ + (fun g -> observe_tac "introducing params" (intro_with_remembrance params princ_info.nparams) g); + (fun g -> observe_tac "introducing predicate" (intro_with_remembrance predicates princ_info.npredicates) g); + (fun g -> observe_tac "introducing branches" (intro_with_remembrance branches princ_info.nbranches) g); + (fun g -> observe_tac "declaring fix(es)" mk_fixes g); + (fun g -> + let nb_prod_g = nb_prod (pf_concl g) in + tclTHENLIST [ + tclDO nb_prod_g intro; + (fun g' -> + let args = + fst (list_chop ~msg:"args" nb_prod_g (pf_ids_of_hyps g')) + in + let do_prove_on_branches branches : tactic = + observe_tac "proving" (do_prove !pte_to_fix args branches) + in + observe_tac "instanciating rec hyps" + (instanciate_hyps_with_args do_prove_on_branches !branches (List.rev args)) + g' + ) + ] + g + ) + ] + goal + + + + + + + + + + + + + + + + + + + + + + + +exception Toberemoved_with_rel of int*constr +exception Toberemoved + +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 type_sort = (Termops.new_sort_in_family InType) in *) + 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 + 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 = + Environ.push_rel_context + new_predicates + (Environ.push_rel_context + princ_type_info.params + env + ) + in + let rel_as_kn = + fst (match princ_type_info.indref with + | Some (Libnames.IndRef ind) -> ind + | _ -> failwith "Not a valid predicate" + ) + 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 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 is_pte = + match kind_of_term f with + | Rel n -> + is_pte (Environ.lookup_rel n env) + | _ -> false + in + let args = + if is_pte && 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 +(* observennl ( *) +(* match kind_of_term pre_princ with *) +(* | Prod _ -> *) +(* str "compute_new_princ_type for "++ *) +(* pr_lconstr_env env pre_princ ++ *) +(* str" is "++ *) +(* pr_lconstr_env env new_princ_type ++ fnl () *) +(* | _ -> str "" *) +(* ); *) + 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 -> +(* msgnl (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) -> +(* msgnl (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 -> +(* msgnl (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) -> +(* msgnl (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 + it_mkProd_or_LetIn + ~init:(it_mkProd_or_LetIn ~init:pre_res 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')) + +(* Things to be removed latter : just here to compare + saving proof with and without normalizing the proof +*) +let new_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 + | Decl_kinds.Local when Lib.sections_are_opened () -> + let k = Decl_kinds.logical_kind_of_goal_kind kind in + let c = Declare.SectionLocalDef (pft, tpo, opacity) in + let _ = Declare.declare_variable id (Lib.cwd(), c, k) in + (Decl_kinds.Local, Libnames.VarRef id) + | Decl_kinds.Local -> + let k = Decl_kinds.logical_kind_of_goal_kind kind in + let kn = Declare.declare_constant id (DefinitionEntry const, k) in + (Decl_kinds.Global, Libnames.ConstRef kn) + | Decl_kinds.Global -> + let k = Decl_kinds.logical_kind_of_goal_kind kind in + let kn = Declare.declare_constant id (DefinitionEntry const, k) in + (Decl_kinds.Global, Libnames.ConstRef kn) in + let time1 = System.get_time () in + Pfedit.delete_current_proof (); + let time2 = System.get_time () in + hook l r; + time1,time2 +(* definition_message id *) + + + + + +let new_save_named opacity = +(* if do_observe () *) +(* then *) + let time1 = System.get_time () in + let id,(const,persistence,hook) = Pfedit.cook_proof () in + let time2 = System.get_time () in + let const = + { const with + const_entry_body = (* nf_betaoiotazeta *)const.const_entry_body ; + const_entry_opaque = opacity + } + in + let time3 = System.get_time () in + let time4,time5 = new_save id const persistence hook in + let time6 = System.get_time () in + Pp.msgnl + (str "cooking proof time : " ++ pp_dur time1 time2 ++ fnl () ++ + str "reducing proof time : " ++ pp_dur time2 time3 ++ fnl () ++ + str "saving proof time : " ++ pp_dur time3 time4 ++fnl () ++ + str "deleting proof time : " ++ pp_dur time4 time5 ++fnl () ++ + str "hook time :" ++ pp_dur time5 time6 + ) + +;; + +(* End of things to be removed latter : just here to compare + saving proof with and without normalizing the proof +*) + + +let generate_functional_principle + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + 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 + (* First we get the type of the old graph principle *) + let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + (* First we get the type of the old graph principle *) + let new_principle_type = + compute_new_princ_type_from_rel + (Array.map mkConst funs) + new_sorts + old_princ_type + in +(* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) + 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 _ _ = + 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) + ) + ); + names := name :: !names + in + register_with_sort InProp; + register_with_sort InSet + in + begin + Command.start_proof + new_princ_name + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + new_principle_type + hook + ; + try + 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; *) + let do_save = not (do_observe ()) && not interactive_proof in + let _ = + try + Options.silently Command.save_named true; + let _dur2 = System.time_difference _tim2 (System.get_time ()) in +(* Pp.msgnl (str ("Time to check proof: ") ++ str (string_of_float dur2)); *) + Options.if_verbose + (fun () -> + Pp.msgnl ( + prlist_with_sep + (fun () -> str" is defined " ++ fnl ()) + Ppconstr.pr_id + (List.rev !names) ++ str" is defined " + ) + ) + () + with e when do_save -> + msg_warning + ( + Cerrors.explain_exn e + ); + if not (do_observe ()) + then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end + in + () + +(* let tim3 = Sys.time () in *) +(* Pp.msgnl (str ("Time to save proof: ") ++ str (string_of_float (tim3 -. tim2))); *) + + with + | e -> + msg_warning + ( + Cerrors.explain_exn e + ); + if not ( do_observe ()) + then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end + end + + + + + + +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 + +let make_scheme fas = + let env = Global.env () + and sigma = Evd.empty in + let id_to_constr id = + Tacinterp.constr_of_id env id + in + let funs = List.map (fun (_,f,_) -> id_to_constr f) fas in + let first_fun = destConst (List.hd funs) in + let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in + let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in + let first_fun_kn = + (* Fixme: take into accour funs_mp and funs_dp *) + fst (destInd (id_to_constr first_fun_rel_id)) + 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 (destConst 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 + let princ_names = List.map (fun (x,_,_) -> x) fas in + let _ = List.map2 + (fun princ_name scheme_type -> + incr i; +(* 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 (Array.of_list sorts)) + (Some princ_name) + this_block_funs + !i + (prove_princ_for_struct false !i (Array.of_list (List.map destConst funs))) + ) + princ_names + l_schemes + in + () + +let make_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,_) -> id_to_constr f) fa in + let first_fun = destConst funs in + let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in + let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in + let first_fun_kn = + (* Fixme: take into accour funs_mp and funs_dp *) + fst (destInd (id_to_constr first_fun_rel_id)) + 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/new_arg_principle.mli b/contrib/funind/new_arg_principle.mli new file mode 100644 index 00000000..cad68da6 --- /dev/null +++ b/contrib/funind/new_arg_principle.mli @@ -0,0 +1,34 @@ + +val generate_functional_principle : + (* do we accept interactive proving *) + bool -> + (* induction principle on rel *) + Term.types -> + (* *) + Term.sorts array option -> + (* Name of the new principle *) + (Names.identifier) option -> + (* the compute functions to use *) + Names.constant array -> + (* We prove the nth- principle *) + int -> + (* The tactic to use to make the proof w.r + the number of params + *) + (Term.constr array -> int -> Tacmach.tactic) -> + unit + + + +(* val my_reflexivity : Tacmach.tactic *) + +val prove_princ_for_struct : + bool -> + int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic + + +val compute_new_princ_type_from_rel : Term.constr array -> Term.sorts array -> + Term.types -> Term.types + +val make_scheme : (Names.identifier*Names.identifier*Rawterm.rawsort) list -> unit +val make_case_scheme : (Names.identifier*Names.identifier*Rawterm.rawsort) -> unit diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml new file mode 100644 index 00000000..327198b9 --- /dev/null +++ b/contrib/funind/rawterm_to_relation.ml @@ -0,0 +1,1012 @@ +open Printer +open Pp +open Names +open Term +open Rawterm +open Libnames +open Indfun_common +open Util +open Rawtermops + +let observe strm = + if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false + then Pp.msgnl strm + else () +let observennl strm = + if Tacinterp.get_debug () <> Tactic_debug.DebugOff &&false + then Pp.msg strm + else () + +(* type binder_type = *) +(* | Lambda *) +(* | Prod *) +(* | LetIn *) + +(* type raw_context = (binder_type*name*rawconstr) list *) + +type binder_type = + | Lambda of name + | Prod of name + | LetIn of name +(* | LetTuple of name list * 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) +(* | LetTuple (nal,na) -> *) +(* RLetTuple(dummy_loc,nal,(na,None),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] +(* | LetTuple(nal,_) -> *) +(* map_succeed (function Name id -> id | _ -> failwith "ids_of_binder") nal *) + +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 rec replace_var_by_term_in_binder x_id term = function *) +(* | [] -> [] *) +(* | (bt,Name id,t)::l when id_ord id x_id = 0 -> *) +(* (bt,Name id,replace_var_by_term x_id term t)::l *) +(* | (bt,na,t)::l -> *) +(* (bt,na,replace_var_by_term x_id term t)::(replace_var_by_term_in_binder x_id term l) *) + +(* let rec change_vars_in_binder mapping = function *) +(* | [] -> [] *) +(* | (bt,(Name id as na),t)::l when Idmap.mem id mapping -> *) +(* (bt,na,change_vars mapping t):: l *) +(* | (bt,na,t)::l -> *) +(* (bt,na,change_vars mapping t):: *) +(* (change_vars_in_binder mapping l) *) + + +(* let alpha_ctxt avoid b = *) +(* let rec alpha_ctxt = function *) +(* | [] -> [],b *) +(* | (bt,n,t)::ctxt -> *) +(* let new_ctxt,new_b = alpha_ctxt ctxt in *) +(* match n with *) +(* | Name id when List.mem id avoid -> *) +(* let new_id = Nameops.next_ident_away id avoid in *) +(* let mapping = Idmap.add id new_id Idmap.empty in *) +(* (bt,Name new_id,t):: *) +(* (change_vars_in_binder mapping new_ctxt), *) +(* change_vars mapping new_b *) +(* | _ -> (bt,n,t)::new_ctxt,new_b *) +(* in *) +(* alpha_ctxt *) +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 add_name na avoid = *) +(* match na with *) +(* | Anonymous -> avoid *) +(* | Name id -> id::avoid *) +(* 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 +(* | LetTuple (nal,na) -> *) +(* let rev_new_nal,mapping,new_avoid = *) +(* List.fold_left *) +(* (fun (nal,mapping,(avoid:identifier list)) na -> *) +(* let new_na,new_mapping,new_avoid = next_name_away na mapping avoid in *) +(* (new_na::nal,new_mapping,new_avoid) *) +(* ) *) +(* ([],Idmap.empty,avoid) *) +(* nal *) +(* in *) +(* (LetTuple(List.rev rev_new_nal,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 combine_tuple nal na b in_e = *) +(* { *) +(* context = b.context@(LetTuple(nal,na),b.value)::in_e.context; *) +(* value = in_e.value *) +(* } *) + +let mk_result ctxt value avoid = + { + result = + [{context = ctxt; + value = value}] + ; + to_avoid = avoid + } + + +let make_discr_match_el = + List.map (fun e -> (e,(Anonymous,None))) + +let coq_True_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") + +let coq_False_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") + +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 + +let make_discr_match brl = + fun el i -> + mkRCases(None, + make_discr_match_el el, + make_discr_match_brl i brl) + + + +let rec make_pattern_eq_precond id e pat : identifier * (binder_type * Rawterm.rawconstr) list = + match pat with + | PatVar(_,Anonymous) -> assert false + | PatVar(_,Name x) -> + id,[Prod (Name x),mkRHole ();Prod Anonymous,raw_make_eq (mkRVar x) e] + | PatCstr(_,constr,patternl,_) -> + let new_id,new_patternl,patternl_eq_precond = + List.fold_right + (fun pat' (id,new_patternl,preconds) -> + match pat' with + | PatVar (_,Name id) -> (id,id::new_patternl,preconds) + | _ -> + let new_id = Nameops.lift_ident id in + let new_id',pat'_precond = + make_pattern_eq_precond new_id (mkRVar id) pat' + in + (new_id',id::new_patternl,preconds@pat'_precond) + ) + patternl + (id,[],[]) + in + 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 cst_as_term = + mkRApp(mkRRef(Libnames.ConstructRef constr), + implicit_args@(List.map mkRVar new_patternl) + ) + in + let precond' = + (Prod Anonymous, raw_make_eq cst_as_term e)::patternl_eq_precond + in + let precond'' = + List.fold_right + (fun id acc -> + (Prod (Name id),(mkRHole ()))::acc + ) + new_patternl + precond' + in + new_id,precond'' + +let pr_name = function + | Name id -> Ppconstr.pr_id id + | Anonymous -> str "_" + +let make_pattern_eq_precond id e pat = + let res = make_pattern_eq_precond id e pat in + observe + (prlist_with_sep spc + (function (Prod na,t) -> + str "forall " ++ pr_name na ++ str ":" ++ pr_rawconstr t + | _ -> assert false + ) + (snd res) + ); + res + + +let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = +(* Pp.msgnl (str " Entering : " ++ Printer.pr_rawconstr rt); *) + match rt with + | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> + mk_result [] rt avoid + | RApp(_,_,_) -> + let f,args = raw_decompose_app rt in + let args_res : (rawconstr list) build_entry_return = + List.fold_right + (fun arg ctxt_argsl -> + let arg_res = build_entry_lc 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 -> + 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),mkRHole (); + 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 _ -> + { + 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 *) + | RLetIn(_,n,t,b) -> + 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 + funnames + avoid + (mkRLetIn(new_n,t,mkRApp(new_b,args))) + | RCases _ | RLambda _ -> + let f_res = build_entry_lc funnames args_res.to_avoid f in + combine_results combine_app f_res args_res + | RDynamic _ ->error "Not handled RDynamic" + | RCast _ -> error "Not handled RCast" + | RRec _ -> error "Not handled RRec" + | RIf _ -> error "Not handled RIf" + | RLetTuple _ -> error "Not handled RLetTuple" + | RProd _ -> error "Cannot apply a type" + end + | RLambda(_,n,t,b) -> + let b_res = build_entry_lc funnames avoid b in + let t_res = build_entry_lc funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + combine_results (combine_lam new_n) t_res b_res + | RProd(_,n,t,b) -> + let b_res = build_entry_lc funnames avoid b in + let t_res = build_entry_lc funnames avoid t in + combine_results (combine_prod n) t_res b_res + | RLetIn(_,n,t,b) -> + let b_res = build_entry_lc funnames avoid b in + let t_res = build_entry_lc funnames avoid t in + combine_results (combine_letin n) t_res b_res + | RCases(_,_,el,brl) -> + let make_discr = make_discr_match brl in + build_entry_lc_from_case funnames make_discr el brl avoid + | RIf _ -> error "Not handled RIf" + | RLetTuple _ -> error "Not handled RLetTuple" + | RRec _ -> error "Not handled RRec" + | RCast _ -> error "Not handled RCast" + | RDynamic _ -> error "Not handled RDynamic" +and build_entry_lc_from_case funname make_discr + (el:(Rawterm.rawconstr * + (Names.name * (loc * Names.inductive * Names.name list) option) ) + list) + (brl:(loc * identifier list * cases_pattern list * rawconstr) list) avoid : + rawconstr build_entry_return = + match el with + | [] -> assert false (* matched on Nothing !*) + | el -> + let case_resl = + List.fold_right + (fun (case_arg,_) ctxt_argsl -> + let arg_res = build_entry_lc funname avoid case_arg in + combine_results combine_args arg_res ctxt_argsl + ) + el + (mk_result [] [] avoid) + in + let results = + List.map + (build_entry_lc_from_case_term funname make_discr [] 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 funname make_discr patterns_to_prevent brl avoid + matched_expr = + match brl with + | [] -> (* computed_branches *) {result = [];to_avoid = avoid} + | br::brl' -> + let _,idl,patl,return = alpha_br avoid br in + let new_avoid = idl@avoid in +(* let e_ctxt,el = (matched_expr.context,matched_expr.value) in *) +(* if (List.length patl) <> (List.length el) *) +(* then error ("Pattern matching on product: not yet implemented"); *) + let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = + List.map + (fun pat -> + fun avoid pat'_as_term -> + let renamed_pat,_,_ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + List.fold_right + (fun id acc -> mkRProd (Name id,mkRHole (),acc)) + pat_ids + (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) + ) + patl + in + 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 + let brl'_res = + build_entry_lc_from_case_term + funname + make_discr + ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) + brl' + avoid + matched_expr + in +(* let ids = List.map (fun id -> Prod (Name id),mkRHole ()) idl in *) + let those_pattern_preconds = +( List.flatten + ( + List.map2 + (fun pat e -> + let this_pat_ids = ids_of_pat pat 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),mkRHole ())::acc + else acc + + ) + idl + [(Prod Anonymous,raw_make_eq pat_as_term e)] + ) + patl + matched_expr.value + ) +) + @ + (if List.exists (function (unifl,neql) -> + let (unif,eqs) = + 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 + [(Prod Anonymous,make_discr (List.map pattern_to_term patl) i )] + else + [] + ) + in + let return_res = build_entry_lc funname new_avoid return in + let this_branch_res = + List.map + (fun res -> + { context = + matched_expr.context@ +(* ids@ *) + 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 + +(* 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 + 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 + -> + 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 +(* 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 *) +(* let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types 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) *) +(* | _ -> *) +(* RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude *) + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in +(* let new_b,id_to_exclude = rebuild_cons relname (args new_crossed_types b 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 + + +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 + +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 + +(* (Topconstr.CProdN + (dummy_loc, + [[(dummy_loc,Anonymous)],returned_types.(i)], + Topconstr.CSort(dummy_loc, RProp Null ) + ) + ) +*) +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, RProp Null)) + + +let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) returned_types (rtl:rawconstr list) = +(* 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 + let rtl_alpha = List.map (function rt -> (alpha_rt [] rt) ) rtl in + let rta = Array.of_list rtl_alpha in + let relnames = Array.map mk_rel_id funnames in + let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + let resa = Array.map (build_entry_lc funnames_as_set []) rta in + 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 +(* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *) + fst ( + rebuild_cons nb_args relnames.(i) +(* (List.map *) +(* (function *) +(* (Anonymous,_,_) -> mkRVar(fresh_id res.to_avoid "x__") *) +(* | Name id, _,_ -> mkRVar id *) +(* ) *) +(* funsargs.(i) *) +(* ) *) + [] + [] + rt + ) + ) + res.result + in + let next_constructor_id = ref (-1) in + let mk_constructor_id i = + incr next_constructor_id; + 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 = + List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + in + let rel_constructors = Array.mapi rel_constructors resa in + let rels_params = + if parametrize + then + compute_params_name relnames_as_set funsargs rel_constructors + else [] + in + let nrel_params = List.length rels_params in + let rel_constructors = + Array.map (List.map + (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) + rel_constructors + in + let rel_arity i funargs = + 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)) +(* (Topconstr.CProdN *) +(* (dummy_loc, *) +(* [[(dummy_loc,Anonymous)],returned_types.(i)], *) +(* Topconstr.CSort(dummy_loc, RProp Null ) *) +(* ) *) +(* ) *) + in + let rel_arities = Array.mapi rel_arity funsargs in + let old_rawprint = !Options.raw_print in + Options.raw_print := true; + 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),Constrextern.extern_rawtype Idset.empty t) + )) + rel_constructors + in + let rel_ind i ext_rel_constructors = + (dummy_loc,relnames.(i)), + None, + rel_params, + rel_arities.(i), + ext_rel_constructors + in + let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let rel_inds = Array.to_list ext_rel_constructors in + let _ = + 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 () ++ + 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 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 + Impargs.make_implicit_args false; + Impargs.make_strict_implicit_args false; + Impargs.make_contextual_implicit_args false; + try + Options.silently (Command.build_mutual rel_inds) true; + 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; + with + | UserError(s,msg) -> + 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; + let msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ + msg + in + observe (msg); + raise + (UserError(s, msg)) + | 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; + 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 + (UserError("",msg)) + + diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli new file mode 100644 index 00000000..0cda56df --- /dev/null +++ b/contrib/funind/rawterm_to_relation.mli @@ -0,0 +1,16 @@ + +(* val new_build_entry_lc : *) +(* Names.identifier list -> *) +(* (Names.name*Rawterm.rawconstr) list list -> *) +(* Topconstr.constr_expr list -> *) +(* Rawterm.rawconstr list -> *) +(* unit *) + +val build_inductive : + bool -> + Names.identifier list -> + (Names.name*Rawterm.rawconstr*bool) list list -> + Topconstr.constr_expr list -> + Rawterm.rawconstr list -> + unit + diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml new file mode 100644 index 00000000..99bf2bf1 --- /dev/null +++ b/contrib/funind/rawtermops.ml @@ -0,0 +1,525 @@ +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) + + +(* + 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_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 t1 t2 = + mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[mkRHole ();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 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(_,Name id,_,_) when Idmap.mem id mapping -> rt + | RLambda(loc,name,t,b) -> + RLambda(loc, + name, + change_vars mapping t, + change_vars mapping b + ) + | RProd(_,Name id,_,_) when Idmap.mem id mapping -> rt + | RProd(loc,name,t,b) -> + RProd(loc, + name, + change_vars mapping t, + change_vars mapping b + ) + | RLetIn(_,Name id,_,_) when Idmap.mem id mapping -> rt + | RLetIn(loc,name,def,b) -> + RLetIn(loc, + name, + change_vars mapping def, + change_vars mapping b + ) + | RLetTuple(_,nal,(na,_),_,_) when List.exists (function Name id -> Idmap.mem id mapping | _ -> false) (na::nal) -> rt + | RLetTuple(loc,nal,(na,rto),b,e) -> + RLetTuple(loc, + nal, + (na, option_app (change_vars mapping) rto), + change_vars mapping b, + change_vars 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 _ -> error "Not handled RIf" + | RRec _ -> error "Not handled RRec" + | 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 + (replace 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 + (replace 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 + (replace 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_app replace rto,replace 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_app (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 _ -> error "Not handled RIf" + | 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 + if Tacinterp.get_debug () <> Tactic_debug.DebugOff && false + then + Pp.msgnl (str "debug: alpha_rt(" ++ str "[" ++ + prlist_with_sep (fun _ -> str";") Ppconstr.pr_id excluded ++ + str "]" ++ spc () ++ str "," ++ spc () ++ + Printer.pr_rawconstr rt ++ spc () ++ str ")" ++ spc () ++ str "=" ++ + spc () ++ Printer.pr_rawconstr new_rt + ); + 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_app 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 _ -> raise (UserError("",str "Not handled RIf")) + | 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 + diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli new file mode 100644 index 00000000..92df0ec6 --- /dev/null +++ b/contrib/funind/rawtermops.mli @@ -0,0 +1,111 @@ +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 * + (rawconstr * (Names.name * (Util.loc * Names.inductive * Names.name list) option)) list * + (Util.loc * Names.identifier list * cases_pattern list * rawconstr) list -> + rawconstr +val mkRSort : rawsort -> rawconstr +val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) + +(* + 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_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 : 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 diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 index 1500e1ae..c2410d55 100644 --- a/contrib/funind/tacinv.ml4 +++ b/contrib/funind/tacinv.ml4 @@ -46,6 +46,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 +58,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 +71,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 +179,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 +205,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 +444,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 +577,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 +597,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 +657,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 +696,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 +735,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 +755,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,8 +772,8 @@ 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) ] +TACTIC EXTEND functional_induction + [ "functional" "induction" constr(c) ne_constr_list(l) ] -> [ invfun_verif c l true ] END @@ -780,13 +789,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,38 +812,46 @@ 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 () VERNAC COMMAND EXTEND FunctionalScheme [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" - constr(c) "with" ne_constr_list(l) ] + ident(c) "with" ne_ident_list(l) ] -> [ declareFunScheme c na l ] -| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" constr(c) ] +| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ] -> [ declareFunScheme c na [] ] END diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml index a125b9a7..2877c19d 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 @@ -74,7 +74,7 @@ let rec mkevarmap_from_listex lex = let _ = prconstr typ in*) let info ={ evar_concl = typ; - evar_hyps = empty_named_context; + evar_hyps = empty_named_context_val; evar_body = Evar_empty} in Evd.add (mkevarmap_from_listex lex') ex info @@ -126,7 +126,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 +144,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 +187,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 +237,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 +269,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..fb71288a 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -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,7 @@ 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_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 +670,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,7 +684,7 @@ 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_replace_with of ct_FORMULA * ct_FORMULA * ct_ID_OPT * ct_TACTIC_OPT | 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_right of ct_SPEC_LIST diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index d5236a7a..21f977f1 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;; @@ -94,7 +91,7 @@ let rec def_const_in_term_rec vl x = 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 + | Cast(x,_,t)-> def_const_in_term_rec vl t | Const(c) -> def_const_in_term_rec vl (lookup_constant c vl).const_type | _ -> def_const_in_term_rec vl (type_of vl Evd.empty 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..8fcdb5d9 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 {const_type=typ} = Global.lookup_constant (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..578abc49 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -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..56abfb82 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 = rawwit_tactic Pcoq.Tactic.tactic_main_level +let globwit_main_tactic = globwit_tactic Pcoq.Tactic.tactic_main_level +let wit_main_tactic = wit_tactic Pcoq.Tactic.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;; -(* -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..b06ba199 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 *) @@ -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);; @@ -173,9 +153,9 @@ let constant_to_ast_list kn = 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..4d4df59f 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 -> @@ -395,13 +329,13 @@ let add_path_action reqid string_arg = 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 7844 2006-01-11 16:36:14Z bertot $");; 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..b7da5c1b 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,7 +150,7 @@ 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')} ;; @@ -163,26 +162,6 @@ let rule_is_complex r = |_ -> 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 @@ -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 @@ -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 @@ -759,7 +724,7 @@ let rec nsortrec vl x = nsortrec vl (mkInd (inductive_of_constructor c)) | Case(_,x,t,a) -> nsortrec vl x - | Cast(x,t)-> nsortrec vl t + | Cast(x,_, t)-> nsortrec vl t | Const c -> nsortrec vl (lookup_constant c vl).const_type | _ -> nsortrec vl (type_of vl Evd.empty 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..5a7ccc26 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -407,6 +407,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 +421,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 +457,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 +1160,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 +1288,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 +1553,9 @@ 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_exists(x1) -> fSPEC_LIST x1; fNODE "exists" 1 @@ -1649,12 +1660,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,10 +1708,12 @@ 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 + fID_OPT x3; + fTACTIC_OPT x4; + fNODE "replace_with" 4 | CT_rewrite_lr(x1, x2, x3) -> fFORMULA x1; fSPEC_LIST x2; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 02dc57de..da87086e 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;; @@ -266,11 +261,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)) @@ -373,14 +370,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 +387,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 +415,10 @@ 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) = if bl = [] then 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,14 +469,14 @@ let xlate_hyp = function let xlate_hyp_location = function - | AI (_,id), nums, (InHypTypeOnly,_) -> + | AI (_,id), nums, InHypTypeOnly -> CT_intype(xlate_ident id, nums_to_int_list nums) - | AI (_,id), nums, (InHypValueOnly,_) -> + | AI (_,id), nums, InHypValueOnly -> CT_invalue(xlate_ident id, nums_to_int_list nums) - | AI (_,id), [], (InHyp,_) -> + | AI (_,id), [], InHyp -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | AI (_,id), a::l, (InHyp,_) -> + | AI (_,id), a::l, 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))) @@ -631,6 +615,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 @@ -678,9 +663,11 @@ let xlate_one_unfold_block = function | (n::nums, qid) -> CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);; -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 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 rawwit_main_tactic = rawwit_tactic Pcoq.Tactic.tactic_main_level let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = function @@ -729,6 +716,7 @@ 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)) -> @@ -788,6 +776,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 +787,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 +804,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 +845,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 @@ -914,7 +909,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 @@ -962,53 +957,68 @@ 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 (_,"replace", [c1; c2;id_opt;tac_opt]) -> + let c1 = xlate_formula (out_gen rawwit_constr c1) in + let c2 = xlate_formula (out_gen rawwit_constr c2) in + let id_opt = + match out_gen Extratactics.rawwit_in_arg_hyp id_opt with + | None -> ctv_ID_OPT_NONE + | Some id -> ctf_ID_OPT_SOME (xlate_ident id) + in + let tac_opt = + match out_gen (Extratactics.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,id_opt,tac_opt) | 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]) -> + | TacExtend (_,"rewrite_in", [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 + let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var 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 (_,"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 +1031,7 @@ 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) | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) | TacDestructConcl -> CT_dconcl @@ -1031,14 +1042,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,11 +1061,11 @@ 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 @@ -1063,6 +1076,10 @@ and xlate_tac = | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s | Some ArgArg n -> xlate_int_to_id_or_int_opt n | None -> none_in_id_or_int_opt in + let _lems = + match out_gen Eauto.rawwit_auto_using lems with + | [] -> [] + | _ -> xlate_error "TODO: eauto using" in let idl = out_gen Eauto.rawwit_hintbases idl in (match idl with None -> CT_eauto_with(first_n, @@ -1084,12 +1101,14 @@ and xlate_tac = 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 +1130,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 +1142,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 +1168,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 +1207,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 +1243,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 +1263,14 @@ 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 + | TacticArgType n -> + let t = xlate_tactic (out_gen (rawwit_tactic n) x) in CT_coerce_TACTIC_COM_to_TARG t - | OpenConstrArgType -> - CT_coerce_SCOMMENT_CONTENT_to_TARG - (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula - (snd (out_gen - rawwit_open_constr x)))) - | CastedOpenConstrArgType -> + | OpenConstrArgType b -> 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)))) | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" | BindingsArgType -> xlate_error "TODO: generic with bindings" | RedExprArgType -> xlate_error "TODO: generic red expr" @@ -1315,8 +1340,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 +1360,10 @@ 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 + | TacticArgType n -> + let t = xlate_tactic (out_gen (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 +1374,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 +1524,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 @@ -1643,18 +1657,13 @@ let rec xlate_vernac = CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1, ainv1, fth1, ainvl1, bind) |_ -> 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 +1674,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 +1684,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 +1704,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 +1725,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,6 +1757,7 @@ 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 _)" | VernacGo arg -> CT_go (xlate_locn arg) | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l) | VernacShow ExplainTree l -> @@ -1775,6 +1774,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 +1784,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) @@ -1867,13 +1871,12 @@ let rec xlate_vernac = 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) = if bl = [] then 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,8 +1888,8 @@ 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) -> + | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" + | VernacCoFixpoint ((lm :: lmi),boxed) -> let strip_mutcorec (fid, bl, arf, ardef) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in @@ -1916,20 +1919,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,8 +1944,6 @@ 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) @@ -1966,8 +1965,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 +1979,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 +1987,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 +1998,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 = @@ -2032,8 +2028,6 @@ let rec xlate_vernac = (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)) @@ -2057,6 +2051,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 +2108,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 +2118,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..ee3301d7 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 7837 2006-01-11 09:47:32Z 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]) @@ -156,22 +172,22 @@ let constant = 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 (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 +199,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 +233,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 +256,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") @@ -304,7 +320,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 +340,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 +417,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 +425,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 +459,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 +476,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 +490,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 +511,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 +523,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 +532,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 +544,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 +581,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 +620,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 +628,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 +641,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 +657,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 +679,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 +736,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 +746,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 +758,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 +779,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 +791,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 +823,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 +845,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 +884,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 +896,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 +937,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 +956,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 +964,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 +979,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 +998,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 +1013,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 +1034,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 +1075,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 +1093,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 +1148,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 +1171,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 +1185,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 +1202,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 +1241,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 +1264,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 +1345,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 +1353,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 +1362,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 +1382,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 +1393,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 +1413,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 +1444,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 +1461,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 +1564,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 +1665,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 +1776,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..cf09e63a --- /dev/null +++ b/contrib/recdef/recdef.ml4 @@ -0,0 +1,1385 @@ +(************************************************************************) +(* 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 h_intros l = + tclMAP h_intro l + +let do_observe_tac s tac g = + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + try let v = tac g in msgnl (goal ++ fnl () ++ (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 = 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 -> + (Global.lookup_constant sp).const_type + |_ -> 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 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 -> + (* For now we suppose that the function takes only one argument. *) + (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::tl -> + (match find_aux tl with + (cf, ((arg1::args) as opt_args)) -> + (match find_call_occs f a with + cf2, (_ :: _ as other_args) -> + let len1 = List.length other_args in + (fun l -> + cf2 l::(cf (nthtl(l,len1)))), other_args@opt_args + | _, [] -> (fun x -> a::cf x), opt_args) + | _, [] -> + (match find_call_occs f a with + cf, (arg1::args) -> (fun l -> cf l::tl), (arg1::args) + | _, [] -> (fun x -> a::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(_,_,_) -> error "find_call_occs : cast" + | 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 = + let ids = pf_ids_of_hyps g in + match kind_of_term expr with + | Lambda (n, _, b) -> + let n1 = + match n with + Name x -> x + | Anonymous -> ano_id + in + let new_n = next_global_ident_away true n1 ids 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 = next_global_ident_away true teq_id ids in + tclTHEN (h_intro teq) + (cont_function (mkVar teq::eqs) expr) 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 + +let tclUSER is_mes l g = + let b,l = + match l with + None -> true,[] + | Some l -> false,l + in + tclTHENSEQ + [ + (h_clear b l); + 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 ids = pf_ids_of_hyps g in + let k' = next_global_ident_away true k_id ids in + let h = next_global_ident_away true h_id (k'::ids) 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 -> + 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];; + + +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]); + h_intros [k;h';def]; + simpl_iter(); + unfold_in_concl[([1],evaluable_of_global_reference func)]; + list_rewrite true eqs; + list_cond_rewrite k def bound cond_eqs le_proofs; + 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 "" + done; + with Invalid_argument _ -> failwith "" + +let retrieve_acc_var g = + (* Julien: I don't like this version .... *) + let hyps = pf_ids_of_hyps g in + map_succeed + (fun id -> + try + string_match (string_of_id id); + id + with _ -> failwith "") + hyps + +let rec introduce_all_values is_mes acc_inv func context_fn + eqs hrec args values specs = + (match args with + [] -> + tclTHENLIST + [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 = introduce_all_values is_mes acc_inv func context_fn eqs + hrec args + (rec_res::values)(hspec::specs) in + (tclTHENS + (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) + [tclTHENLIST [h_intros [rec_res; hspec]; + tac]; + (tclTHENS + (apply (Lazy.force acc_inv)) + [ h_assumption + ; + (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 rec proveterminate is_mes acc_inv (hrec:identifier) + (f_constr:constr) (func:global_reference) (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 is_mes acc_inv hrec f_constr func) + 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 -> + msgerrnl(str "failure in proveterminate"); + raise e +*) +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 -> + msgerrnl(str "failure in proveterminate"); + raise e + 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 = + if is_mes + then + tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings)) + else tclUSER is_mes None + +let start 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 of the well_foundness of the relation *) + wf_tac is_mes; + (* well_foundness -> Acc for any element *) + 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 -> assert false + 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 + | _ -> assert false + ) + ([],(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 + start + 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 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 + | [] -> assert false + | [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 build_new_goal_type () = + let sub_gls_types = get_current_subgoals_types () in + let res = build_and_l sub_gls_types in + res + + + +let interpretable_as_section_decl d1 d2 = match d1,d2 with + | (_,Some _,_), (_,None,_) -> false + | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2 + | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 + + + + +(* let final_decompose lemma n : tactic = *) +(* fun gls -> *) +(* let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in *) +(* tclTHENSEQ *) +(* [ *) +(* generalize [lemma]; *) +(* tclDO *) +(* n *) +(* (tclTHENSEQ *) +(* [h_intro hid; *) +(* h_case (mkVar hid,Rawterm.NoBindings); *) +(* clear [hid]; *) +(* intro_patterns [Genarg.IntroWildcard] *) +(* ] *) +(* ); *) +(* h_intro hid; *) +(* tclTRY *) +(* (tclTHENSEQ [h_case (mkVar hid,Rawterm.NoBindings); *) +(* clear [hid]; *) +(* h_intro hid; *) +(* intro_patterns [Genarg.IntroWildcard] *) +(* ]); *) +(* e_resolve_constr (mkVar hid); *) +(* e_assumption *) +(* ] *) +(* gls *) + + + +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 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 _ -> assert false + + 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 v = let lemme = mkConst (Lib.make_con na) in *) +(* Tactics.exact_no_check *) +(* (applist (lemme, *) +(* List.rev (Array.to_list (Sign.instance_from_named_context sign)))) *) +(* gls in *) + + let hook _ _ = + let lemma = mkConst (Lib.make_con na) in + Array.iteri (fun i _ -> by (observe_tac "tac" (prove_with_tcc lemma i))) (Array.make nb_goal ()); + ref := Some lemma ; + Command.save_named true; + in + start_proof + na + (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) + sign + gls_type + hook ; + by (decompose_and_tac); + () + +let com_terminate ref is_mes fonctional_ref input_type relation rec_arg_num + thm_name 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 )); + open_new_goal ref + None + (build_new_goal_type ()) + + + + +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; + unfold_constr f; + simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))); + 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 + (mk_intros_and_continue true + (prove_eq termine f functional) eqs) + (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_expr -> unit) = + fun eq_name functional_ref f_ref terminate_ref eq -> + let (evmap, env) = Command.get_current_context() in + let eq_constr = interp_constr evmap env eq in + let f_constr = (constr_of_reference f_ref) in + (start_proof eq_name (Global, Proof Lemma) + (Environ.named_context_val env) eq_constr (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) + ) + ) + ); + Command.save_named true);; + + +let recursive_definition is_mes f type_of_f r rec_arg_num eq + generate_induction_principle : unit = + let function_type = interp_constr Evd.empty (Global.env()) type_of_f in + let env = push_rel (Name f,None,function_type) (Global.env()) in + let res_vars,eq' = decompose_prod (interp_constr Evd.empty env eq) in + let res = +(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) +(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) + match kind_of_term eq' with + | App(e,[|_;_;eq_fix|]) -> + mkLambda (Name f,function_type,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 f "_equation" in + let functional_id = add_suffix f "_F" in + let term_id = add_suffix f "_terminate" in + let functional_ref = declare_fun functional_id (IsDefinition Definition) res in +(* let _ = Pp.msgnl (str "res := " ++ Printer.pr_lconstr 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_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 f (IsProof Lemma) arg_types term_ref in +(* let _ = message "start second proof" in *) + com_eqn equation_id functional_ref f_ref term_ref eq; + let eq_ref = Nametab.locate (make_short_qualid equation_id ) in + generate_induction_principle tcc_lemma_constr + functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; + () + + in + com_terminate + tcc_lemma_constr + is_mes functional_ref + rec_arg_type + relation rec_arg_num + term_id + hook +;; + + + +(* let observe_tac = do_observe_tac *) + +let base_leaf_princ eq_cst functional_ref eqs expr = + tclTHENSEQ + [rewriteLR (mkConst eq_cst); + tclTRY (list_rewrite true eqs); + gen_eauto(* default_eauto *) false (false,5) [] (Some []) + ] + + + +let prove_with_tcc 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 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); + gen_eauto(* default_eauto *) false (false,5) [] (Some []) + (* default_auto *) + ] + gls + + + +let finalize_rec_leaf_princ_with tcc_lemma_constr is_mes hrec acc_inv eqs br = + fun g -> + tclTHENSEQ [ + Eauto.e_resolve_constr (mkVar br); + tclFIRST + [ + e_assumption; + reflexivity; + tclTHEN (apply (mkVar hrec)) + (tclTHENS + (* (try *) (observe_tac "applying inversion" (apply (Lazy.force acc_inv))) +(* with e -> Pp.msgnl (Printer.pr_lconstr (Lazy.force acc_inv));raise e *) +(* ) *) + [ h_assumption + ; + tclTHEN + (fun g -> + tclUSER + is_mes + (Some (hrec::(retrieve_acc_var g))) + g + ) + (fun g -> prove_with_tcc tcc_lemma_constr eqs g) + ] + ); + gen_eauto(* default_eauto *) false (false,5) [] (Some []); + (fun g -> tclIDTAC_MESSAGE (str "here" ++ Printer.pr_goal (sig_it g)) g) + ] + ] + g + +let rec_leaf_princ + tcc_lemma_constr + eq_cst + branches_names + is_mes + acc_inv + hrec + (functional_ref:global_reference) + eqs + expr + = + fun g -> + tclTHENSEQ + [ rewriteLR (mkConst eq_cst); + list_rewrite true eqs; + tclFIRST + (List.map (finalize_rec_leaf_princ_with tcc_lemma_constr is_mes hrec acc_inv eqs) branches_names) + ] + g + +let fresh_id avoid na = + let id = + match na with + | Name id -> id + | Anonymous -> h_id + in + next_global_ident_away true id avoid + + + +let prove_principle tcc_lemma_ref is_mes functional_ref + eq_ref rec_arg_num rec_arg_type nb_args relation = +(* f_ref eq_ref rec_arg_num rec_arg_type nb_args relation *) + let eq_cst = + match eq_ref with + ConstRef sp -> sp + | _ -> assert false + in + fun g -> + let type_of_goal = pf_concl g in + let goal_ids = pf_ids_of_hyps g in + let goal_elim_infos = compute_elim_sig type_of_goal in + let params_names,ids = List.fold_left + (fun (params_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::params_names,new_id::avoid) + ) + ([],goal_ids) + goal_elim_infos.params + in + let predicates_names,ids = + List.fold_left + (fun (predicates_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::predicates_names,new_id::avoid) + ) + ([],ids) + goal_elim_infos.predicates + in + let branches_names,ids = + List.fold_left + (fun (branches_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::branches_names,new_id::avoid) + ) + ([],ids) + goal_elim_infos.branches + in + let to_intro = params_names@predicates_names@branches_names in + let nparams = List.length params_names in + let rec_arg_num = rec_arg_num - nparams in + begin + tclTHEN + (h_intros to_intro) + (observe_tac (string_of_int (rec_arg_num)) + (fun g -> + let ids = ids_of_named_context (pf_hyps g) in + let func_body = (def_of_const (constr_of_reference functional_ref)) in +(* let _ = Pp.msgnl (Printer.pr_lconstr func_body) 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 -> assert false + 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 + | _ -> assert false + ) + ([],(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 + start + is_mes + rec_arg_type + ids + (snd (list_chop nparams n_ids)) + (substl (List.map mkVar params_names) relation) + (rec_arg_num) + rec_arg_id + (fun hrec acc_inv g -> + (proveterminate + is_mes + acc_inv + hrec + (mkVar f_id) + functional_ref + (base_leaf_princ eq_cst) + (rec_leaf_princ tcc_lemma_ref eq_cst branches_names) + [] + expr + ) + g + ) + (if is_mes + then + tclUSER_if_not_mes + else fun _ -> prove_with_tcc tcc_lemma_ref []) + + g + ) + ) + end + g + + + +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) ] -> + [ 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/ArithRing.v index 1a6e0ba6..68464c10 100644 --- a/contrib/ring/ArithRing.v +++ b/contrib/ring/ArithRing.v @@ -6,7 +6,7 @@ (* * 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: ArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) (* Instantiation of the Ring tactic for the naturals of Arith $*) @@ -16,7 +16,7 @@ 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,12 +32,12 @@ 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. @@ -86,4 +86,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/NArithRing.v index cfec29ce..878346ba 100644 --- a/contrib/ring/NArithRing.v +++ b/contrib/ring/NArithRing.v @@ -6,7 +6,7 @@ (* * 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: NArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) (* Instantiation of the Ring tactic for the binary natural numbers *) @@ -15,7 +15,7 @@ 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 @@ -41,4 +41,4 @@ Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. 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 Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N 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.v b/contrib/ring/Ring.v index 81497533..6572e79a 100644 --- a/contrib/ring/Ring.v +++ b/contrib/ring/Ring.v @@ -6,7 +6,7 @@ (* * 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. diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v index de42e8c3..c0818da8 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 6295 2004-11-12 16:40:39Z gregoire $ *) Require Import Ring_theory. Require Import Quote. Require Import Ring_normalize. +Unset Boxed Definitions. + Section abstract_semi_rings. Inductive aspolynomial : Type := @@ -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..7b40328a 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 6295 2004-11-12 16:40:39Z gregoire $ *) Require Import 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. @@ -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/Ring_theory.v b/contrib/ring/Ring_theory.v index dfdfdf66..5536294e 100644 --- a/contrib/ring/Ring_theory.v +++ b/contrib/ring/Ring_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: Ring_theory.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Bool. 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/ZArithRing.v b/contrib/ring/ZArithRing.v index c511c076..3999b632 100644 --- a/contrib/ring/ZArithRing.v +++ b/contrib/ring/ZArithRing.v @@ -6,7 +6,7 @@ (* * 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: ZArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) (* Instantiation of the Ring tactic for the binary integers of ZArith *) @@ -14,7 +14,7 @@ Require Export ArithRing. Require Export ZArith_base. Require Import Eqdep_dec. -Definition Zeq (x y:Z) := +Unboxed Definition Zeq (x y:Z) := match (x ?= y)%Z with | Datatypes.Eq => true | _ => false @@ -27,10 +27,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 + [ Zpos Zneg 0%Z xO xI 1%positive ]. 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..dccd1944 100644 --- a/contrib/ring/g_ring.ml4 +++ b/contrib/ring/g_ring.ml4 @@ -8,13 +8,13 @@ (*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 7734 2005-12-26 14:06:51Z herbelin $ *) open Quote open Ring -TACTIC EXTEND Ring - [ "Ring" constr_list(l) ] -> [ polynom l ] +TACTIC EXTEND ring + [ "ring" constr_list(l) ] -> [ polynom l ] END (* The vernac commands "Add Ring" and co *) diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index bda04db3..462e5ed8 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 7639 2005-12-02 10:01:15Z gregoire $ *) (* 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,7 +297,7 @@ 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 + | Cast(c,_,_) -> closed_under cset c | App(f,l) -> closed_under cset f & array_for_all (closed_under cset) l | _ -> false) @@ -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..5251dcc5 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 7837 2006-01-11 09:47:32Z herbelin $ *) (* 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 @@ -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";"Ring"]; 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..2aa3516f 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,13 @@ Inductive term : Set := | Topp : term -> term | Tvar : nat -> term. +Delimit Scope romega_scope with term. +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 +77,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 +130,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 +140,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 +186,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 +370,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 +492,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 +508,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 +520,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 +543,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 +554,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 +577,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 +609,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 +627,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 +653,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 +662,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 +679,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 +695,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 +711,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 +724,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 +759,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 +841,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 +875,6 @@ Ltac loop t := | Timp x x0 => _ | Tprop x => _ end => - - (* Eliminations *) case X1; [ intro; intro | intro; intro @@ -907,19 +891,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 +939,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 +950,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 +961,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 +972,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 +983,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 +994,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 +1005,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 +1021,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 +1033,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 +1045,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 +1074,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 +1089,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 +1101,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 +1113,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 +1125,7 @@ Qed. Definition Topp_opp (t : term) := match t with - | Topp (Topp x) => x + | (- - x)%term => x | _ => t end. @@ -1158,7 +1136,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 +1147,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 +1158,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 +1169,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 +1180,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 +1189,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 +1198,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 +1213,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 +1232,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 +1248,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 +1261,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 +1272,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 +1291,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 +1390,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 +1406,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 +1475,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 +1485,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 +1525,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 +1540,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 +1562,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 +1588,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 +1624,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 +1636,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 +1659,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 +1673,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 +1708,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 +1738,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 +1773,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 +1794,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 +1824,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 +1835,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 +1851,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 +1874,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 +1896,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 +1909,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 +1930,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 +1940,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 +1949,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 +1970,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 +2002,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 +2080,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 +2117,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 +2133,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 +2142,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 +2209,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 +2226,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 +2238,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 +2247,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 +2281,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 +2315,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 +2457,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 +2513,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 +2532,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 +2613,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 +2624,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 +2651,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 +2689,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 +2701,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 +2715,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..97d80a92 --- /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 7233 2005-07-15 12:34:56Z corbinea $ *) + +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. + +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/rtauto/g_rtauto.ml4 b/contrib/rtauto/g_rtauto.ml4 new file mode 100644 index 00000000..d7bb6e31 --- /dev/null +++ b/contrib/rtauto/g_rtauto.ml4 @@ -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 *) +(************************************************************************) + +(* $Id: g_rtauto.ml4 7734 2005-12-26 14:06:51Z herbelin $*) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +TACTIC EXTEND rtauto + [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ] +END + diff --git a/contrib/rtauto/proof_search.ml b/contrib/rtauto/proof_search.ml 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..445dead2 --- /dev/null +++ b/contrib/rtauto/refl_tauto.ml @@ -0,0 +1,338 @@ +(************************************************************************) +(* 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 7639 2005-12-02 10:01:15Z gregoire $ *) + +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 nhyps = List.length hyps 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/BinList.v b/contrib/setoid_ring/BinList.v new file mode 100644 index 00000000..0def087f --- /dev/null +++ b/contrib/setoid_ring/BinList.v @@ -0,0 +1,101 @@ +Set Implicit Arguments. +Require Import BinPos. +Open Scope positive_scope. + + +Section LIST. + + Variable A:Type. + Variable default:A. + + Inductive list : Type := + | nil : list + | cons : A -> list -> list. + + Infix "::" := cons (at level 60, right associativity). + + Definition hd l := match l with hd :: _ => hd | _ => default end. + + Definition tl l := match l with _ :: tl => tl | _ => nil end. + + Fixpoint jump (p:positive) (l:list) {struct p} : list := + match p with + | xH => tl l + | xO p => jump p (jump p l) + | xI p => jump p (jump p (tl l)) + end. + + Fixpoint nth (p:positive) (l:list) {struct p} : A:= + match p with + | xH => hd l + | xO p => nth p (jump p l) + | xI p => nth p (jump p (tl l)) + end. + + Fixpoint rev_append (rev l : list) {struct l} : list := + match l with + | nil => rev + | (cons h t) => rev_append (cons h rev) t + end. + + Definition rev l : list := rev_append nil l. + + Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl 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) (tl 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 (tl l) = hd (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) (tl 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 LIST. diff --git a/contrib/setoid_ring/Pol.v b/contrib/setoid_ring/Pol.v new file mode 100644 index 00000000..2bf2574f --- /dev/null +++ b/contrib/setoid_ring/Pol.v @@ -0,0 +1,1195 @@ +Set Implicit Arguments. +Require Import Setoid. +Require Export BinList. +Require Import BinPos. +Require Import BinInt. +Require Export Ring_th. + +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. + + + (* 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 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. + + (** 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. + + 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 => + Padd (mkPX (Pmul_aux P P') i P0) (PmulI Pmul_aux Q xH P') + end. + Notation "P ** P'" := (Pmul P P'). + + (** Evaluation of a polynomial towards R *) + + Fixpoint pow (x:R) (i:positive) {struct i}: R := + match i with + | xH => x + | xO i => let p := pow x i in p * p + | xI i => let p := pow x i in x * p * p + end. + + 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 x i in + (Pphi l P) * xi + (Pphi (tl 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 pow_Psucc : forall x j, pow x (Psucc j) == x * pow x j. + Proof. + induction j;simpl;rsimpl. + rewrite IHj;rsimpl;mul_push x;rrefl. + Qed. + + Lemma pow_Pplus : forall x i j, pow x (i + j) == pow x i * pow 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_Psucc. + simpl;rsimpl. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi;rsimpl. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_Psucc; + simpl;rsimpl. + 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. + + Lemma mkPX_ok : forall l P i Q, + (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tl 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_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_sym 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 (hd 0 l) p));rrefl. + rewrite IHP'2;simpl. + rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl. add_push (P @ (tl l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1;rewrite IHP'2;rsimpl. + add_push (P3 @ (tl l));rewrite H;rrefl. + rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_Pplus;rsimpl. + add_push (P3 @ (tl l));rrefl. + assert (forall P k l, + (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow (hd 0 l) k). + induction P;simpl;intros;try apply (ARadd_sym ARth). + destruct p2;simpl;try apply (ARadd_sym ARth). + rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth). + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. + rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tl l0));rrefl. + rewrite IHP'1;simpl;Esimpl. + rewrite H1;rewrite Pplus_comm. + rewrite pow_Pplus;simpl;Esimpl. + add_push (P5 @ (tl l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_Pplus;simpl;rsimpl. + add_push (P5 @ (tl l0));rrefl. + rewrite H0;rsimpl. + add_push (P3 @ (tl l)). + rewrite H;rewrite Pplus_comm. + rewrite IHP'2;rewrite pow_Pplus;rsimpl. + add_push (P3 @ (tl 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_sym 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 (hd 0 l) p));trivial. + add_push (P @ (jump p0 (jump p0 (tl l))));rrefl. + rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. + add_push (- (P'1 @ l * pow (hd 0 l) p));rrefl. + rewrite IHP'2;rsimpl;add_push (P @ (tl l));rrefl. + assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. + rewrite IHP'1; rewrite IHP'2;rsimpl. + add_push (P3 @ (tl l));rewrite H;rrefl. + rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. + rewrite H;rewrite Pplus_comm. + rewrite pow_Pplus;rsimpl. + add_push (P3 @ (tl l));rrefl. + assert (forall P k l, + (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow (hd 0 l) k). + induction P;simpl;intros. + rewrite Popp_ok;rsimpl;apply (ARadd_sym ARth);trivial. + destruct p2;simpl;rewrite Popp_ok;rsimpl. + apply (ARadd_sym ARth);trivial. + rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth);trivial. + apply (ARadd_sym ARth);trivial. + assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. + rewrite IHP'1;rsimpl;add_push (P5 @ (tl l0));rewrite H1;rrefl. + rewrite IHP'1;rewrite H1;rewrite Pplus_comm. + rewrite pow_Pplus;simpl;Esimpl. + add_push (P5 @ (tl l0));rrefl. + rewrite IHP1;rewrite H1;rewrite Pplus_comm. + rewrite pow_Pplus;simpl;rsimpl. + add_push (P5 @ (tl l0));rrefl. + rewrite H0;rsimpl. + rewrite IHP'2;rsimpl;add_push (P3 @ (tl l)). + rewrite H;rewrite Pplus_comm. + rewrite pow_Pplus;rsimpl. + 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_sym 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 (hd 0 l) p);rrefl. + rewrite IHP1;rewrite IHP2;simpl;rsimpl. + mul_push (pow (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. + rewrite IHP1;simpl;rsimpl. + mul_push (pow (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. + + Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Proof. + destruct P;simpl;intros. + Esimpl2;apply (ARmul_sym ARth). + rewrite (PmulI_ok P (Pmul_aux_ok P)). + apply (ARmul_sym ARth). + rewrite Padd_ok; Esimpl2. + rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. + rewrite Pmul_aux_ok;mul_push (P' @ l). + rewrite (ARmul_sym ARth (P' @ l));rrefl. + 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. + + (** normalisation towards polynomials *) + + Definition X := (PX P1 xH P0). + + Definition mkX j := + match j with + | xH => X + | xO j => Pinj (Pdouble_minus_one j) X + | xI j => Pinj (xO j) X + end. + + Fixpoint norm (pe:PExpr) : Pol := + match pe with + | PEc c => Pc c + | PEX j => mkX j + | PEadd pe1 (PEopp pe2) => Psub (norm pe1) (norm pe2) + | PEadd (PEopp pe1) pe2 => Psub (norm pe2) (norm pe1) + | PEadd pe1 pe2 => Padd (norm pe1) (norm pe2) + | PEsub pe1 pe2 => Psub (norm pe1) (norm pe2) + | PEmul pe1 pe2 => Pmul (norm pe1) (norm pe2) + | PEopp pe1 => Popp (norm pe1) + end. + + (** 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) + end. + + (** Correctness proofs *) + + + Lemma mkX_ok : forall p l, nth 0 p l == (mkX 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. + + Lemma norm_PEopp : forall l pe, (norm (PEopp pe))@l == -(norm pe)@l. + Proof. + intros;simpl;apply Popp_ok. + 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) + | |- context [(norm (PEopp ?pe))@?l] => rewrite (norm_PEopp l pe) + end;Esimpl2;try rrefl;try apply (ARadd_sym ARth). + + Lemma norm_ok : forall l pe, PEeval l pe == (norm pe)@l. + Proof. + induction pe;simpl;Esimpl3. + apply mkX_ok. + rewrite IHpe1;rewrite IHpe2; destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite Pmul_ok;rewrite IHpe1;rewrite IHpe2;rrefl. + rewrite IHpe;rrefl. + Qed. + + Lemma ring_correct : forall l pe1 pe2, + ((norm pe1) ?== (norm pe2)) = true -> (PEeval l pe1) == (PEeval l pe2). + Proof. + intros l pe1 pe2 H. + repeat rewrite norm_ok. + apply (Peq_ok (norm pe1) (norm pe2) H l). + Qed. + +(** Evaluation function avoiding parentheses *) + Fixpoint mkmult (r:R) (lm:list R) {struct lm}: R := + match lm with + | nil => r + | cons h t => mkmult (r*h) t + end. + + Definition mkadd_mult rP lm := + match lm with + | nil => rP + 1 + | cons h t => rP + mkmult h t + end. + + Fixpoint powl (i:positive) (x:R) (l:list R) {struct i}: list R := + match i with + | xH => cons x l + | xO i => powl i x (powl i x l) + | xI i => powl i x (powl i x (cons x l)) + end. + + Fixpoint add_mult_dev (rP:R) (P:Pol) (fv lm:list R) {struct P} : R := + (* rP + P@l * lm *) + match P with + | Pc c => if c ?=! cI then mkadd_mult rP (rev lm) + else mkadd_mult rP (cons [c] (rev lm)) + | Pinj j Q => add_mult_dev rP Q (jump j fv) lm + | PX P i Q => + let rP := add_mult_dev rP P fv (powl i (hd 0 fv) lm) in + if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm + end. + + Definition mkmult1 lm := + match lm with + | nil => rI + | cons h t => mkmult h t + end. + + Fixpoint mult_dev (P:Pol) (fv lm : list R) {struct P} : R := + (* P@l * lm *) + match P with + | Pc c => if c ?=! cI then mkmult1 (rev lm) else mkmult [c] (rev lm) + | Pinj j Q => mult_dev Q (jump j fv) lm + | PX P i Q => + let rP := mult_dev P fv (powl i (hd 0 fv) lm) in + if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm + end. + + Definition Pphi_dev fv P := mult_dev P fv (nil R). + + Add Morphism mkmult : mkmult_ext. + intros r r0 eqr l;generalize l r r0 eqr;clear l r r0 eqr; + induction l;simpl;intros. + trivial. apply IHl; rewrite eqr;rrefl. + Qed. + + Lemma mul_mkmult : forall lm r1 r2, r1 * mkmult r2 lm == mkmult (r1*r2) lm. + Proof. + induction lm;simpl;intros;try rrefl. + rewrite IHlm. + setoid_replace (r1 * (r2 * a)) with (r1 * r2 * a);Esimpl. + Qed. + + Lemma mkmult1_mkmult : forall lm r, r * mkmult1 lm == mkmult r lm. + Proof. + destruct lm;simpl;intros. Esimpl. + apply mul_mkmult. + Qed. + + Lemma mkmult1_mkmult_1 : forall lm, mkmult1 lm == mkmult 1 lm. + Proof. + intros;rewrite <- mkmult1_mkmult;Esimpl. + Qed. + + Lemma mkmult_rev_append : forall lm l r, + mkmult r (rev_append l lm) == mkmult (mkmult r l) lm. + Proof. + induction lm; simpl in |- *; intros. + rrefl. + rewrite IHlm; simpl in |- *. + repeat rewrite <- (ARmul_sym ARth a); rewrite <- mul_mkmult. + rrefl. + Qed. + + Lemma powl_mkmult_rev : forall p r x lm, + mkmult r (rev (powl p x lm)) == mkmult (pow x p * r) (rev lm). + Proof. + induction p;simpl;intros. + repeat rewrite IHp. + unfold rev;simpl. + repeat rewrite mkmult_rev_append. + simpl. + setoid_replace (pow x p * (pow x p * r) * x) + with (x * pow x p * pow x p * r);Esimpl. + mul_push x;rrefl. + repeat rewrite IHp. + setoid_replace (pow x p * (pow x p * r) ) + with (pow x p * pow x p * r);Esimpl. + unfold rev;simpl. repeat rewrite mkmult_rev_append;simpl. + rewrite (ARmul_sym ARth);rrefl. + Qed. + + Lemma Pphi_add_mult_dev : forall P rP fv lm, + rP + P@fv * mkmult1 (rev lm) == add_mult_dev rP P fv lm. + Proof. + induction P;simpl;intros. + assert (H := (morph_eq CRmorph) c cI). + destruct (c ?=! cI). + rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl. + destruct (rev lm);Esimpl;rrefl. + rewrite mkmult1_mkmult;rrefl. + apply IHP. + replace (match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end) with (Peq P3 P0);trivial. + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + rewrite (H (refl_equal true));simpl;Esimpl. + rewrite <- IHP1. + repeat rewrite mkmult1_mkmult_1. + rewrite powl_mkmult_rev. + rewrite <- mul_mkmult;Esimpl. + rewrite <- IHP2. + rewrite <- IHP1. + repeat rewrite mkmult1_mkmult_1. + rewrite powl_mkmult_rev. + rewrite <- mul_mkmult;Esimpl. + Qed. + + Lemma Pphi_mult_dev : forall P fv lm, + P@fv * mkmult1 (rev lm) == mult_dev P fv lm. + Proof. + induction P;simpl;intros. + assert (H := (morph_eq CRmorph) c cI). + destruct (c ?=! cI). + rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl. + apply mkmult1_mkmult. + apply IHP. + replace (match P3 with + | Pc c => c ?=! cO + | Pinj _ _ => false + | PX _ _ _ => false + end) with (Peq P3 P0);trivial. + assert (H := Peq_ok P3 P0). + destruct (P3 ?== P0). + rewrite (H (refl_equal true));simpl;Esimpl. + rewrite <- IHP1. + repeat rewrite mkmult1_mkmult_1. + rewrite powl_mkmult_rev. + rewrite <- mul_mkmult;Esimpl. + rewrite <- Pphi_add_mult_dev. + rewrite <- IHP1. + repeat rewrite mkmult1_mkmult_1. + rewrite powl_mkmult_rev. + rewrite <- mul_mkmult;Esimpl. + Qed. + + Lemma Pphi_Pphi_dev : forall P l, P@l == Pphi_dev l P. + Proof. + unfold Pphi_dev;intros. + rewrite <- Pphi_mult_dev;simpl;Esimpl. + Qed. + + Lemma Pphi_dev_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). + Proof. + intros l pe;rewrite <- Pphi_Pphi_dev;apply norm_ok. + Qed. + + Lemma Pphi_dev_ok' : + forall l pe npe, norm pe = npe -> PEeval l pe == Pphi_dev l npe. + Proof. + intros l pe npe npe_eq; subst npe; apply Pphi_dev_ok. + Qed. + +(* The same but building a PExpr *) +(* + Fixpoint Pmkmult (r:PExpr) (lm:list PExpr) {struct lm}: PExpr := + match lm with + | nil => r + | cons h t => Pmkmult (PEmul r h) t + end. + + Definition Pmkadd_mult rP lm := + match lm with + | nil => PEadd rP (PEc cI) + | cons h t => PEadd rP (Pmkmult h t) + end. + + Fixpoint Ppowl (i:positive) (x:PExpr) (l:list PExpr) {struct i}: list PExpr := + match i with + | xH => cons x l + | xO i => Ppowl i x (Ppowl i x l) + | xI i => Ppowl i x (Ppowl i x (cons x l)) + end. + + Fixpoint Padd_mult_dev + (rP:PExpr) (P:Pol) (fv lm:list PExpr) {struct P} : PExpr := + (* rP + P@l * lm *) + match P with + | Pc c => if c ?=! cI then Pmkadd_mult rP (rev lm) + else Pmkadd_mult rP (cons [PEc c] (rev lm)) + | Pinj j Q => Padd_mult_dev rP Q (jump j fv) lm + | PX P i Q => + let rP := Padd_mult_dev rP P fv (Ppowl i (hd P0 fv) lm) in + if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm + end. + + Definition Pmkmult1 lm := + match lm with + | nil => PEc cI + | cons h t => Pmkmult h t + end. + + Fixpoint Pmult_dev (P:Pol) (fv lm : list PExpr) {struct P} : PExpr := + (* P@l * lm *) + match P with + | Pc c => if c ?=! cI then Pmkmult1 (rev lm) else Pmkmult [PEc c] (rev lm) + | Pinj j Q => Pmult_dev Q (jump j fv) lm + | PX P i Q => + let rP := Pmult_dev P fv (Ppowl i (hd (PEc r0) fv) lm) in + if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm + end. + + Definition Pphi_dev2 fv P := Pmult_dev P fv (nil PExpr). + +... +*) + (************************************************) + (* avec des parentheses mais un peu plus efficace *) + + + (************************************************** + + Fixpoint pow_mult (i:positive) (x r:R){struct i}:R := + match i with + | xH => r * x + | xO i => pow_mult i x (pow_mult i x r) + | xI i => pow_mult i x (pow_mult i x (r * x)) + end. + + Definition pow_dev i x := + match i with + | xH => x + | xO i => pow_mult (Pdouble_minus_one i) x x + | xI i => pow_mult (xO i) x x + end. + + Lemma pow_mult_pow : forall i x r, pow_mult i x r == pow x i * r. + Proof. + induction i;simpl;intros. + rewrite (IHi x (pow_mult i x (r * x)));rewrite (IHi x (r*x));rsimpl. + mul_push x;rrefl. + rewrite (IHi x (pow_mult i x r));rewrite (IHi x r);rsimpl. + apply ARth.(ARmul_sym). + Qed. + + Lemma pow_dev_pow : forall p x, pow_dev p x == pow x p. + Proof. + destruct p;simpl;intros. + rewrite (pow_mult_pow p x (pow_mult p x x)). + rewrite (pow_mult_pow p x x);rsimpl;mul_push x;rrefl. + rewrite (pow_mult_pow (Pdouble_minus_one p) x x). + rewrite (ARth.(ARmul_sym) (pow x (Pdouble_minus_one p)) x). + rewrite <- (pow_Psucc x (Pdouble_minus_one p)). + rewrite Psucc_o_double_minus_one_eq_xO;simpl; rrefl. + rrefl. + Qed. + + Fixpoint Pphi_dev (fv:list R) (P:Pol) {struct P} : R := + match P with + | Pc c => [c] + | Pinj j Q => Pphi_dev (jump j fv) Q + | PX P i Q => + let rP := mult_dev P fv (pow_dev i (hd 0 fv)) in + add_dev rP Q (tl fv) + end + + with add_dev (ra:R) (P:Pol) (fv:list R) {struct P} : R := + match P with + | Pc c => if c ?=! cO then ra else ra + [c] + | Pinj j Q => add_dev ra Q (jump j fv) + | PX P i Q => + let ra := add_mult_dev ra P fv (pow_dev i (hd 0 fv)) in + add_dev ra Q (tl fv) + end + + with mult_dev (P:Pol) (fv:list R) (rm:R) {struct P} : R := + match P with + | Pc c => if c ?=! cI then rm else [c]*rm + | Pinj j Q => mult_dev Q (jump j fv) rm + | PX P i Q => + let ra := mult_dev P fv (pow_mult i (hd 0 fv) rm) in + add_mult_dev ra Q (tl fv) rm + end + + with add_mult_dev (ra:R) (P:Pol) (fv:list R) (rm:R) {struct P} : R := + match P with + | Pc c => if c ?=! cO then ra else ra + [c]*rm + | Pinj j Q => add_mult_dev ra Q (jump j fv) rm + | PX P i Q => + let rmP := pow_mult i (hd 0 fv) rm in + let raP := add_mult_dev ra P fv rmP in + add_mult_dev raP Q (tl fv) rm + end. + + Lemma Pphi_add_mult_dev : forall P ra fv rm, + add_mult_dev ra P fv rm == ra + P@fv * rm. + Proof. + induction P;simpl;intros. + assert (H := CRmorph.(morph_eq) c cO). + destruct (c ?=! cO). + rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl. + rrefl. + apply IHP. + rewrite (IHP2 (add_mult_dev ra P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm). + rewrite (IHP1 ra fv (pow_mult p (hd 0 fv) rm)). + rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl. + Qed. + + Lemma Pphi_add_dev : forall P ra fv, add_dev ra P fv == ra + P@fv. + Proof. + induction P;simpl;intros. + assert (H := CRmorph.(morph_eq) c cO). + destruct (c ?=! cO). + rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl. + rrefl. + apply IHP. + rewrite (IHP2 (add_mult_dev ra P2 fv (pow_dev p (hd 0 fv))) (tl fv)). + rewrite (Pphi_add_mult_dev P2 ra fv (pow_dev p (hd 0 fv))). + rewrite (pow_dev_pow p (hd 0 fv));rsimpl. + Qed. + + Lemma Pphi_mult_dev : forall P fv rm, mult_dev P fv rm == P@fv * rm. + Proof. + induction P;simpl;intros. + assert (H := CRmorph.(morph_eq) c cI). + destruct (c ?=! cI). + rewrite (H (refl_equal true));rewrite CRmorph.(morph1);Esimpl. + rrefl. + apply IHP. + rewrite (Pphi_add_mult_dev P3 + (mult_dev P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm). + rewrite (IHP1 fv (pow_mult p (hd 0 fv) rm)). + rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl. + Qed. + + Lemma Pphi_Pphi_dev : forall P fv, P@fv == Pphi_dev fv P. + Proof. + induction P;simpl;intros. + rrefl. trivial. + rewrite (Pphi_add_dev P3 (mult_dev P2 fv (pow_dev p (hd 0 fv))) (tl fv)). + rewrite (Pphi_mult_dev P2 fv (pow_dev p (hd 0 fv))). + rewrite (pow_dev_pow p (hd 0 fv));rsimpl. + Qed. + + Lemma Pphi_dev_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). + Proof. + intros l pe;rewrite <- (Pphi_Pphi_dev (norm pe) l);apply norm_ok. + Qed. + + Ltac Trev l := + let rec rev_append rev l := + match l with + | (nil _) => constr:(rev) + | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t + end in + rev_append (nil R) l. + + Ltac TPphi_dev add mul := + let tl l := match l with (cons ?h ?t) => constr:(t) end in + let rec jump j l := + match j with + | xH => tl l + | (xO ?j) => let l := jump j l in jump j l + | (xI ?j) => let t := tl l in let l := jump j l in jump j l + end in + let rec pow_mult i x r := + match i with + | xH => constr:(mul r x) + | (xO ?i) => let r := pow_mult i x r in pow_mult i x r + | (xI ?i) => + let r := constr:(mul r x) in + let r := pow_mult i x r in + pow_mult i x r + end in + let pow_dev i x := + match i with + | xH => x + | (xO ?i) => + let i := eval compute in (Pdouble_minus_one i) in pow_mult i x x + | (xI ?i) => pow_mult (xO i) x x + end in + let rec add_mult_dev ra P fv rm := + match P with + | (Pc ?c) => + match eval compute in (c ?=! cO) with + | true => constr:ra + | _ => let rc := eval compute in [c] in constr:(add ra (mul rc rm)) + end + | (Pinj ?j ?Q) => + let fv := jump j fv in add_mult_dev ra Q fv rm + | (PX ?P ?i ?Q) => + match fv with + | (cons ?hd ?tl) => + let rmP := pow_mult i hd rm in + let raP := add_mult_dev ra P fv rmP in + add_mult_dev raP Q tl rm + end + end in + let rec mult_dev P fv rm := + match P with + | (Pc ?c) => + match eval compute in (c ?=! cI) with + | true => constr:rm + | false => let rc := eval compute in [c] in constr:(mul rc rm) + end + | (Pinj ?j ?Q) => let fv := jump j fv in mult_dev Q fv rm + | (PX ?P ?i ?Q) => + match fv with + | (cons ?hd ?tl) => + let rmP := pow_mult i hd rm in + let ra := mult_dev P fv rmP in + add_mult_dev ra Q tl rm + end + end in + let rec add_dev ra P fv := + match P with + | (Pc ?c) => + match eval compute in (c ?=! cO) with + | true => ra + | false => let rc := eval compute in [c] in constr:(add ra rc) + end + | (Pinj ?j ?Q) => let fv := jump j fv in add_dev ra Q fv + | (PX ?P ?i ?Q) => + match fv with + | (cons ?hd ?tl) => + let rmP := pow_dev i hd in + let ra := add_mult_dev ra P fv rmP in + add_dev ra Q tl + end + end in + let rec Pphi_dev fv P := + match P with + | (Pc ?c) => eval compute in [c] + | (Pinj ?j ?Q) => let fv := jump j fv in Pphi_dev fv Q + | (PX ?P ?i ?Q) => + match fv with + | (cons ?hd ?tl) => + let rm := pow_dev i hd in + let rP := mult_dev P fv rm in + add_dev rP Q tl + end + end in + Pphi_dev. + + **************************************************************) + +End MakeRingPol. diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v new file mode 100644 index 00000000..6c3f87a5 --- /dev/null +++ b/contrib/setoid_ring/Ring_tac.v @@ -0,0 +1,754 @@ +Set Implicit Arguments. +Require Import Setoid. +Require Import BinList. +Require Import BinPos. +Require Import Pol. +Declare ML Module "newring". + +(* Some Tactics *) + +Ltac compute_assertion id t := + let t' := eval compute in t in + (assert (id : t = t'); [exact_no_check (refl_equal t')|idtac]). + +Ltac compute_assertion' id id' t := + let t' := eval compute in t in + (pose (id' := t'); + assert (id : t = id'); + [exact_no_check (refl_equal id')|idtac]). + +Ltac compute_replace' id t := + let t' := eval compute in t in + (replace t with t' in id; [idtac|exact_no_check (refl_equal t')]). + +Ltac bin_list_fold_right fcons fnil l := + match l with + | (cons ?x ?tl) => fcons x ltac:(bin_list_fold_right fcons fnil tl) + | (nil _) => fnil + end. + +Ltac bin_list_fold_left fcons fnil l := + match l with + | (cons ?x ?tl) => bin_list_fold_left fcons ltac:(fcons x fnil) tl + | (nil _) => fnil + end. + +Ltac bin_list_iter f l := + match l with + | (cons ?x ?tl) => f x; bin_list_iter f tl + | (nil _) => idtac + end. + +(** A tactic that reverses a list *) +Ltac Trev R l := + let rec rev_append rev l := + match l with + | (nil _) => constr:(rev) + | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t + end in + rev_append (nil R) l. + +(* to avoid conflicts with Coq booleans*) +Definition NotConstant := false. + +Ltac IN a l := + match l with + | (cons a ?l) => true + | (cons _ ?l) => IN a l + | (nil _) => false + end. + +Ltac AddFv a l := + match (IN a l) with + | true => l + | _ => constr:(cons a l) + end. + +Ltac Find_at a l := + match l with + | (nil _) => fail 1 "ring anomaly" + | (cons a _) => constr:1%positive + | (cons _ ?l) => let p := Find_at a l in eval compute in (Psucc p) + end. + +Ltac FV Cst add mul sub opp 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 + | _ => AddFv t fv + end + | _ => fv + end + in TFV t fv. + + (* syntaxification *) + Ltac mkPolexpr C Cst radd rmul rsub ropp t fv := + let rec mkP t := + match Cst t with + | 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) + | _ => + let p := Find_at t fv in constr:(PEX C p) + end + | ?c => constr:(PEc c) + end + in mkP t. + +(* ring tactics *) +Ltac Make_ring_rewrite_step lemma pe:= + let npe := fresh "npe" in + let H := fresh "eq_npe" in + let Heq := fresh "ring_thm" in + let npe_spec := + match type of (lemma pe) with + forall (npe:_), ?npe_spec = npe -> _ => npe_spec + | _ => fail 1 "cannot find norm expression" + end in + (compute_assertion' H npe npe_spec; + assert (Heq:=lemma _ _ H); clear H; + protect_fv in Heq; + (rewrite Heq; clear Heq npe) || clear npe). + + +Ltac Make_ring_rw_list Cst_tac lemma req rl := + match type of lemma with + forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), + _ = npe -> + req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => + let mkFV := FV Cst_tac add mul sub opp in + let mkPol := mkPolexpr C Cst_tac add mul sub opp in + (* build the atom list *) + let rfv := bin_list_fold_left mkFV (nil R) rl in + let fv := Trev R rfv in + (* rewrite *) + bin_list_iter + ltac:(fun r => + let pe := mkPol r fv in + Make_ring_rewrite_step (lemma fv) pe) + rl + | _ => fail 1 "bad lemma" + end. + +Ltac Make_ring_rw Cst_tac lemma req r := + Make_ring_rw_list Cst_tac lemma req (cons r (nil _)). + + (* Building the generic tactic *) + + Ltac Make_ring_tac Cst_tac lemma1 lemma2 req := + match type of lemma2 with + forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), + _ = npe -> + req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => + match goal with + | |- req ?r1 ?r2 => + let mkFV := FV Cst_tac add mul sub opp in + let mkPol := mkPolexpr C Cst_tac add mul sub opp in + let rfv := mkFV (add r1 r2) (nil R) in + let fv := Trev R rfv in + let pe1 := mkPol r1 fv in + let pe2 := mkPol r2 fv in + ((apply (lemma1 fv pe1 pe2); + vm_compute; + exact (refl_equal true)) || + (Make_ring_rewrite_step (lemma2 fv) pe1; + Make_ring_rewrite_step (lemma2 fv) pe2)) + | _ => fail 1 "goal is not an equality from a declared ring" + end + end. + + +(* coefs belong to the same type as the target ring (concrete ring) *) +Definition ring_id_correct + R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := + @ring_correct R rO rI radd rmul rsub ropp req rSet req_th ARth + R rO rI radd rmul rsub ropp reqb + (@IDphi R) + (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). + +Definition ring_rw_id_correct + R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := + @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th ARth + R rO rI radd rmul rsub ropp reqb + (@IDphi R) + (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). + +Definition ring_rw_id_correct' + R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := + @Pphi_dev_ok' R rO rI radd rmul rsub ropp req rSet req_th ARth + R rO rI radd rmul rsub ropp reqb + (@IDphi R) + (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). + +Definition ring_id_eq_correct R rO rI radd rmul rsub ropp ARth reqb reqb_ok := + @ring_id_correct R rO rI radd rmul rsub ropp (@eq R) + (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. + +Definition ring_rw_id_eq_correct + R rO rI radd rmul rsub ropp ARth reqb reqb_ok := + @ring_rw_id_correct R rO rI radd rmul rsub ropp (@eq R) + (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. + +Definition ring_rw_id_eq_correct' + R rO rI radd rmul rsub ropp ARth reqb reqb_ok := + @ring_rw_id_correct' R rO rI radd rmul rsub ropp (@eq R) + (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. + +(* +Require Import ZArith. +Require Import Setoid. +Require Import Ring_tac. +Import BinList. +Import Ring_th. +Open Scope Z_scope. + +Add New Ring Zr : (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) + Computational Zeqb_ok + Constant Zcst. + +Goal forall a b, (a+b*2)*(a+b*2)=1. +intros. + setoid ring ((a + b * 2) * (a + b * 2)). + + Make_ring_rw_list Zcst + (ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) + (eq (A:=Z)) + (cons ((a+b)*(a+b)) (nil _)). + + +Goal forall a b, (a+b)*(a+b)=1. +intros. +Ltac zringl := + Make_ring_rw3_list ltac:(inv_gen_phiZ 0 1 Zplus Zmult Zopp) + (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) + (eq (A:=Z)) +(BinList.cons ((a+b)*(a+b)) (BinList.nil _)). + +Open Scope Z_scope. + +let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in +let lemma := + constr:(ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in +let req := constr:(eq (A:=Z)) in +let rl := constr:(cons ((a+b)*(a+b)) (nil _)) in +Make_ring_rw_list Cst_tac lemma req rl. + +let fv := constr:(cons a (cons b (nil _))) in +let pe := + constr:(PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in +Make_ring_rewrite_step (lemma fv) pe. + + + + +OK + +Lemma L0 : + forall (l : list Z) (pe : PExpr Z) pe', + pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe -> + PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe = + Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'. +intros; subst pe'. +apply + (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). +Qed. +Lemma L0' : + forall (l : list Z) (pe : PExpr Z) pe', + norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe = pe' -> + PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe = + Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'. +intros; subst pe'. +apply + (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). +Qed. + +pose (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))). +compute_assertion ipattern:H (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe). +let fv := constr:(cons a (cons b (nil _))) in +assert (Heq := L0 fv _ (sym_equal H)); clear H. + protect_fv' in Heq. + rewrite Heq; clear Heq; clear pe. + + +MIEUX (mais taille preuve = taille de pe + taille de nf(pe)... ): + + +Lemma L : + forall (l : list Z) (pe : PExpr Z) pe' (x y :Z), + pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe -> + x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe -> + y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' -> + x=y. +intros; subst x y pe'. +apply + (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). +Qed. +Lemma L' : + forall (l : list Z) (pe : PExpr Z) pe' (x y :Z), + Peq Zeq_bool pe' (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe) = true -> + x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe -> + y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' -> + forall (P:Z->Type), P y -> P x. +intros. + rewrite L with (2:=H0) (3:=H1); trivial. +apply (Peq_ok (Eqsth Z) (Eq_ext _ _ _) + (IDmorph 0 1 Zplus Zminus Zmult Zopp (Eqsth Z) Zeq_bool Zeqb_ok) ). + + (IDmorph (Eqsth Z) (Eq_ext _ _ _) Zeqb_ok). + + + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth)). +Qed. + +eapply L' + with (x:=(a+b)*(a+b)) + (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) + (l:=cons a (cons b (nil Z)));[compute;reflexivity|reflexivity|idtac|idtac];norm_evars;[protect_fv';reflexivity|idtac];norm_evars. + + + + + +set (x:=a). +set (x0:=b). +set (fv:=cons x (cons x0 (nil Z))). +let fv:=constr:(cons a (cons b (nil Z))) in +let lemma := constr : (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in +let pe := + constr : (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in +assert (Heq := lemma fv pe). +set (npe:=norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool + (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))). +fold npe in Heq. +move npe after fv. +let fv' := eval red in fv in +compute in npe. +subst npe. +let fv' := eval red in fv in +compute_without_globals_of (fv',Zplus,0,1,Zmult,Zopp,Zminus) in Heq. +rewrite Heq. +clear Heq fv; subst x x0. + + +simpl in Heq. +unfold Pphi_dev in Heq. +unfold mult_dev in Heq. +unfold P0, Peq in *. +unfold Zeq_bool at 3, Zcompare, Pcompare in Heq. +unfold fv, hd, tl in Heq. +unfold powl, rev, rev_append in Heq. +unfold mkmult1 in Heq. +unfold mkmult in Heq. +unfold add_mult_dev in |- *. +unfold add_mult_dev at 2 in Heq. +unfold P0, Peq at 1 in Heq. +unfold Zeq_bool at 2 3 4 5 6, Zcompare, Pcompare in Heq. +unfold hd, powl, rev, rev_append in Heq. +unfold mkadd_mult in Heq. +unfold mkmult in Heq. +unfold add_mult_dev in Heq. +unfold P0, Peq in Heq. +unfold Zeq_bool, Zcompare, Pcompare in Heq. +unfold hd,powl, rev,rev_append in Heq. +unfold mkadd_mult in Heq. +unfold mkmult in Heq. +unfold IDphi in Heq. + + fv := cons x (cons x0 (nil Z)) + PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)) + Heq : PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) fv + (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) = + Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) fv + (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool + (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))) + + + +let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in +let lemma := + constr:(ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) + (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in +let req := constr:(eq (A:=Z)) in +let rl := constr:(BinList.cons ((a+b)*(a+b)) (BinList.nil _)) in + match type of lemma with + forall (l:list ?R) (pe:PExpr ?C), + req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => + Constant natcst. + + +Require Import Setoid. +Open Scope nat_scope. + +Require Import Ring_th. +Require Import Arith. + +Add New Ring natr : (SRth_ARth (Eqsth nat) natSRth) + Computational nateq_ok + Constant natcst. + + +Require Import Rbase. +Open Scope R_scope. + + Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R). + Proof. + constructor. exact Rplus_0_l. exact Rplus_comm. + intros;symmetry;apply Rplus_assoc. + exact Rmult_1_l. exact Rmult_comm. + intros;symmetry;apply Rmult_assoc. + exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r. + Qed. + +Add New Ring Rr : Rth Abstract. + +Goal forall a b, (a+b*10)*(a+b*10)=1. +intros. + +Module Zring. + Import Zpol. + Import BinPos. + Import BinInt. + +Ltac is_PCst p := + match p with + | xH => true + | (xO ?p') => is_PCst p' + | (xI ?p') => is_PCst p' + | _ => false + end. + +Ltac ZCst t := + match t with + | Z0 => constr:t + | (Zpos ?p) => + match (is_PCst p) with + | false => NotConstant + | _ => constr:t + end + | (Zneg ?p) => + match (is_PCst p) with + | false => NotConstant + | _ => constr:t + end + | _ => NotConstant + end. + +Ltac zring := + Make_ring_tac ZCst + (Zpol.ring_gen_eq_correct Zth) (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). + +Ltac zrewrite := + Make_ring_rw3 ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). + +Ltac zrewrite_list := + Make_ring_rw3_list ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). + +End Zring. +*) + + + +(* +(*** Intanciation for Z*) +Require Import ZArith. +Open Scope Z_scope. + +Module Zring. + Let R := Z. + Let rO := 0. + Let rI := 1. + Let radd := Zplus. + Let rmul := Zmult. + Let rsub := Zminus. + Let ropp := Zopp. + Let Rth := Zth. + Let reqb := Zeq_bool. + Let req_morph := Zeqb_ok. + + (* CE_Entries *) + Let C := R. + Let cO := rO. + Let cI := rI. + Let cadd := radd. + Let cmul := rmul. + Let csub := rsub. + Let copp := ropp. + Let req := (@eq R). + Let ceqb := reqb. + Let phi := @IDphi R. + Let Rsth : Setoid_Theory R req := Eqsth R. + Let Reqe : ring_eq_ext radd rmul ropp req := + (@Eq_ext R radd rmul ropp). + Let ARth : almost_ring_theory rO rI radd rmul rsub ropp req := + (@Rth_ARth R rO rI radd rmul rsub ropp req Rsth Reqe Rth). + Let CRmorph : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi := + (@IDmorph R rO rI radd rmul rsub ropp req Rsth reqb req_morph). + + Definition Peq := Eval red in (Pol.Peq ceqb). + Definition mkPinj := Eval red in (@Pol.mkPinj C). + Definition mkPX := + Eval red; + change (Pol.Peq ceqb) with Peq; + change (@Pol.mkPinj Z) with mkPinj in + (Pol.mkPX cO ceqb). + + Definition P0 := Eval red in (Pol.P0 cO). + Definition P1 := Eval red in (Pol.P1 cI). + + Definition X := + Eval red; change (Pol.P0 cO) with P0; change (Pol.P1 cI) with P1 in + (Pol.X cO cI). + + Definition mkX := + Eval red; change (Pol.X cO cI) with X in + (mkX cO cI). + + Definition PaddC + Definition PaddI + Definition PaddX + + Definition Padd := + Eval red in + + (Pol.Padd cO cadd ceqb) + + Definition PmulC + Definition PmulI + Definition Pmul_aux + Definition Pmul + + Definition PsubC + Definition PsubI + Definition PsubX + Definition Psub + + + + Definition norm := + Eval red; + change (Pol.Padd cO cadd ceqb) with Padd; + change (Pol.Pmul cO cI cadd cmul ceqb) with Pmul; + change (Pol.Psub cO cadd csub copp ceqb) with Psub; + change (Pol.Popp copp) with Psub; + + in + (Pol.norm cO cI cadd cmul csub copp ceqb). + + + +End Zring. + +Ltac is_PCst p := + match p with + | xH => true + | (xO ?p') => is_PCst p' + | (xI ?p') => is_PCst p' + | _ => false + end. + +Ltac ZCst t := + match t with + | Z0 => constr:t + | (Zpos ?p) => + match (is_PCst p) with + | false => NotConstant + | _ => t + end + | (Zneg ?p) => + match (is_PCst p) with + | false => NotConstant + | _ => t + end + | _ => NotConstant + end. + +Ltac zring := + Zring.Make_ring_tac Zplus Zmult Zminus Zopp (@eq Z) ZCst. + +Ltac zrewrite := + Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst. +*) + +(* +(* Instanciation for Bool *) +Require Import Bool. + +Module BCE. + Definition R := bool. + Definition rO := false. + Definition rI := true. + Definition radd := xorb. + Definition rmul := andb. + Definition rsub := xorb. + Definition ropp b:bool := b. + Lemma Rth : ring_theory rO rI radd rmul rsub ropp (@eq bool). + Proof. + constructor. + exact false_xorb. + exact xorb_comm. + intros; symmetry in |- *; apply xorb_assoc. + exact andb_true_b. + exact andb_comm. + exact andb_assoc. + destruct x; destruct y; destruct z; reflexivity. + intros; reflexivity. + exact xorb_nilpotent. + Qed. + + Definition reqb := eqb. + Definition req_morph := eqb_prop. +End BCE. + +Module BEntries := CE_Entries BCE. + +Module Bring := MakeRingPol BEntries. + +Ltac BCst t := + match t with + | true => true + | false => false + | _ => NotConstant + end. + +Ltac bring := + Bring.Make_ring_tac xorb andb xorb (fun b:bool => b) (@eq bool) BCst. + +Ltac brewrite := + Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst. +*) + +(*Module Rring. + +(* Instanciation for R *) +Require Import Rbase. +Open Scope R_scope. + + Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R). + Proof. + constructor. exact Rplus_0_l. exact Rplus_comm. + intros;symmetry;apply Rplus_assoc. + exact Rmult_1_l. exact Rmult_comm. + intros;symmetry;apply Rmult_assoc. + exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r. + Qed. + +Ltac RCst := inv_gen_phiZ 0 1 Rplus Rmul Ropp. + +Ltac rring := + Make_ring_tac RCst + (Zpol.ring_gen_eq_correct Rth) (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). + +Ltac rrewrite := + Make_ring_rw3 RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). + +Ltac rrewrite_list := + Make_ring_rw3_list RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). + +End Rring. +*) +(************************) +(* +(* Instanciation for N *) +Require Import NArith. +Open Scope N_scope. + +Module NCSE. + Definition R := N. + Definition rO := 0. + Definition rI := 1. + Definition radd := Nplus. + Definition rmul := Nmult. + Definition SRth := Nth. + Definition reqb := Neq_bool. + Definition req_morph := Neq_bool_ok. +End NCSE. + +Module NEntries := CSE_Entries NCSE. + +Module Nring := MakeRingPol NEntries. + +Ltac NCst := inv_gen_phiN 0 1 Nplus Nmult. + +Ltac nring := + Nring.Make_ring_tac Nplus Nmult (@SRsub N Nplus) (@SRopp N) (@eq N) NCst. + +Ltac nrewrite := + Nring.Make_ring_rw3 Nplus Nmult (@SRsub N Nplus) (@SRopp N) NCst. + +(* Instanciation for nat *) +Open Scope nat_scope. + +Module NatASE. + Definition R := nat. + Definition rO := 0. + Definition rI := 1. + Definition radd := plus. + Definition rmul := mult. + Lemma SRth : 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. +End NatASE. + +Module NatEntries := ASE_Entries NatASE. + +Module Natring := MakeRingPol NatEntries. + +Ltac natCst t := + match t with + | O => N0 + | (S ?n) => + match (natCst n) with + | NotConstant => NotConstant + | ?p => constr:(Nsucc p) + end + | _ => NotConstant + end. + +Ltac natring := + Natring.Make_ring_tac plus mult (@SRsub nat plus) (@SRopp nat) (@eq nat) natCst. + +Ltac natrewrite := + Natring.Make_ring_rw3 plus mult (@SRsub nat plus) (@SRopp nat) natCst. + +(* Generic tactic, checks the type of the terms and applies the +suitable instanciation*) + +Ltac newring := + match goal with + | |- (?r1 = ?r2) => + match (type of r1) with + | Z => zring + | R => rring + | bool => bring + | N => nring + | nat => natring + end + end. + +*) diff --git a/contrib/setoid_ring/Ring_th.v b/contrib/setoid_ring/Ring_th.v new file mode 100644 index 00000000..9583dd2d --- /dev/null +++ b/contrib/setoid_ring/Ring_th.v @@ -0,0 +1,462 @@ +Require Import Setoid. + Set Implicit Arguments. + + +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 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). + + + +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_sym : 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_sym : 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 missi**) + Record almost_ring_theory : Prop := mk_art { + ARadd_0_l : forall x, 0 + x == x; + ARadd_sym : 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_sym : 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_sym : 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_sym : 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] + }. + 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. + +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_sym SRth) (SRadd_assoc SRth) + (SRmul_1_l SRth) (SRmul_0_l SRth) + (SRmul_sym 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_sym 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_sym Rth). + rewrite <-(Ropp_def Rth (x*y)). + rewrite (Radd_assoc Rth). + rewrite <- (Rdistr_l Rth). + rewrite (Rth.(Radd_sym) (-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_sym Rth) x). + rewrite ((Radd_sym Rth) y). + rewrite <- ((Radd_assoc Rth) (-y)). + rewrite <- ((Radd_assoc Rth) (- x)). + rewrite ((Radd_assoc Rth) y). + rewrite ((Radd_sym Rth) y). + rewrite <- ((Radd_assoc Rth) (- x)). + rewrite ((Radd_assoc Rth) y). + rewrite ((Radd_sym Rth) y);rewrite (Ropp_def Rth). + rewrite ((Radd_sym Rth) (-x) 0);rewrite (Radd_0_l Rth). + apply (Radd_sym 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_sym 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_sym Rth) (Radd_assoc Rth) + (Rmul_1_l Rth) Rmul_0_l (Rmul_sym 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_sym Rth) [x]). + rewrite <- (Radd_assoc Rth). + rewrite <- (Smorph_add Smorph). + rewrite (Ropp_def Cth). + rewrite (Smorph0 Smorph). + rewrite (Radd_sym 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 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_sym ARth) 0) + | rewrite (ARmul_1_l ARth) + | rewrite <- ((ARmul_sym ARth) 1) + | rewrite (ARmul_0_l ARth) + | rewrite <- ((ARmul_sym ARth) 0) + | rewrite (ARdistr_l ARth) + | sreflexivity + | match goal with + | |- context [?z * (?x + ?y)] => rewrite ((ARmul_sym 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_sym) 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_sym) 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_sym 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_sym 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_sym ARth) x); sreflexivity. + Qed. + + Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. + Proof. + intros;rewrite ((ARmul_sym ARth) x y); + rewrite (ARopp_mul_l ARth); apply (ARmul_sym 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. + +(** 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/ZRing_th.v b/contrib/setoid_ring/ZRing_th.v new file mode 100644 index 00000000..9060428b --- /dev/null +++ b/contrib/setoid_ring/ZRing_th.v @@ -0,0 +1,802 @@ +Require Import Ring_th. +Require Import Pol. +Require Import Ring_tac. +Require Import ZArith_base. +Require Import BinInt. +Require Import BinNat. +Require Import Setoid. + Set Implicit Arguments. + +(** 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). + + 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_sym 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. + +(**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. +(* +Section NNMORPHISM. +Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid5. + Ltac rrefl := gen_reflexivity Rsth. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext5. exact Reqe.(Radd_ext). Qed. + Add Morphism rmul : rmul_ext5. exact Reqe.(Rmul_ext). Qed. + Add Morphism ropp : ropp_ext5. exact Reqe.(Ropp_ext). Qed. + + Lemma SReqe : sring_eq_ext radd rmul req. + case Reqe; constructor; trivial. + Qed. + + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Add Morphism rsub : rsub_ext6. 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 SRth : semi_ring_theory 0 1 radd rmul req. + case ARth; constructor; trivial. + Qed. + + Definition NN := prod N N. + Definition gen_phiNN (x:NN) := + rsub (gen_phiN rO rI radd rmul (fst x)) (gen_phiN rO rI radd rmul (snd x)). + Notation "[ x ]" := (gen_phiNN x). + + Definition NNadd (x y : NN) : NN := + (fst x + fst y, snd x + snd y)%N. + Definition NNmul (x y : NN) : NN := + (fst x * fst y + snd x * snd y, fst y * snd x + fst x * snd y)%N. + Definition NNopp (x:NN) : NN := (snd x, fst x)%N. + Definition NNsub (x y:NN) : NN := (fst x + snd y, fst y + snd x)%N. + + + Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y]. + Proof. +intros. +unfold NNadd, gen_phiNN in |- *; simpl in |- *. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +norm. +add_push (- gen_phiN 0 1 radd rmul (snd x)). +rrefl. +Qed. + + Hypothesis ropp_involutive : forall x, - - x == x. + + + Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y]. + Proof. +intros. +unfold NNmul, gen_phiNN in |- *; simpl in |- *. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +repeat rewrite (gen_phiN_mult Rsth SReqe SRth). +norm. +rewrite ropp_involutive. +add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))). +add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)). +rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y)) + (gen_phiN 0 1 radd rmul (snd x))). +rrefl. +Qed. + + Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y]. +intros. +unfold NNsub, gen_phiNN; simpl. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +repeat rewrite (ARsub_def ARth). +repeat rewrite (ARopp_add ARth). +repeat rewrite (ARadd_assoc ARth). +rewrite ropp_involutive. +add_push (- gen_phiN 0 1 radd rmul (fst y)). +add_push ( - gen_phiN 0 1 radd rmul (snd x)). +rrefl. +Qed. + + +Definition NNeqbool (x y: NN) := + andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)). + +Lemma NNeqbool_ok0 : forall x y, + NNeqbool x y = true -> x = y. +unfold NNeqbool in |- *. +intros. +assert (Neq_bool (fst x) (fst y) = true). + generalize H. + case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial. + assert (Neq_bool (snd x) (snd y) = true). + rewrite H0 in H; simpl in |- *; trivial. + generalize H0 H1. + destruct x; destruct y; simpl in |- *. + intros. + replace n with n1. + replace n2 with n0; trivial. + apply Neq_bool_ok; trivial. + symmetry in |- *. + apply Neq_bool_ok; trivial. +Qed. + + +(*gen_phiN satisfies morphism specifications*) + Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req + (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN. + 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 NNMORPHISM. + +Section NSTARMORPHISM. +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 Reqe.(Radd_ext). Qed. + Add Morphism rmul : rmul_ext3. exact Reqe.(Rmul_ext). Qed. + Add Morphism ropp : ropp_ext3. exact Reqe.(Ropp_ext). Qed. + + Lemma SReqe : sring_eq_ext radd rmul req. + case Reqe; constructor; trivial. + Qed. + + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + + Lemma SRth : semi_ring_theory 0 1 radd rmul req. + case ARth; constructor; trivial. + Qed. + + Inductive Nword : Set := + Nlast (p:positive) + | Ndigit (n:N) (w:Nword). + + Fixpoint opp_iter (n:nat) (t:R) {struct n} : R := + match n with + O => t + | S k => ropp (opp_iter k t) + end. + + Fixpoint gen_phiNword (x:Nword) (n:nat) {struct x} : R := + match x with + Nlast p => opp_iter n (gen_phi_pos p) + | Ndigit N0 w => gen_phiNword w (S n) + | Ndigit m w => radd (opp_iter n (gen_phiN m)) (gen_phiNword w (S n)) + end. + Notation "[ x ]" := (gen_phiNword x). + + Fixpoint Nwadd (x y : Nword) {struct x} : Nword := + match x, y with + Nlast p1, Nlast p2 => Nlast (p1+p2)%positive + | Nlast p1, Ndigit n w => Ndigit (Npos p1 + n)%N w + | Ndigit n w, Nlast p1 => Ndigit (n + Npos p1)%N w + | Ndigit n1 w1, Ndigit n2 w2 => Ndigit (n1+n2)%N (Nwadd w1 w2) + end. + Fixpoint Nwmulp (x:positive) (y:Nword) {struct y} : Nword := + match y with + Nlast p => Nlast (x*p)%positive + | Ndigit n w => Ndigit (Npos x * n)%N (Nwmulp x w) + end. + Definition Nwmul (x y : Nword) {struct x} : Nword := + match x with + Nlast k => Nmulp k y + | Ndigit N0 w => Ndigit N0 (Nwmul w y) + | Ndigit (Npos k) w => + Nwadd (Nwmulp k y) (Ndigit N0 (Nwmul w y)) + end. + + Definition Nwopp (x:Nword) : Nword := Ndigit N0 x. + Definition Nwsub (x y:NN) : NN := (Nwadd x (Ndigit N0 y)). + + + Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y]. + Proof. +intros. +unfold NNadd, gen_phiNN in |- *; simpl in |- *. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +norm. +add_push (- gen_phiN 0 1 radd rmul (snd x)). +rrefl. +Qed. + + Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y]. + Proof. +intros. +unfold NNmul, gen_phiNN in |- *; simpl in |- *. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +repeat rewrite (gen_phiN_mult Rsth SReqe SRth). +norm. +rewrite ropp_involutive. +add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))). +add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)). +rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y)) + (gen_phiN 0 1 radd rmul (snd x))). +rrefl. +Qed. + + Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y]. +intros. +unfold NNsub, gen_phiNN; simpl. +repeat rewrite (gen_phiN_add Rsth SReqe SRth). +repeat rewrite (ARsub_def ARth). +repeat rewrite (ARopp_add ARth). +repeat rewrite (ARadd_assoc ARth). +rewrite ropp_involutive. +add_push (- gen_phiN 0 1 radd rmul (fst y)). +add_push ( - gen_phiN 0 1 radd rmul (snd x)). +rrefl. +Qed. + + +Definition NNeqbool (x y: NN) := + andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)). + +Lemma NNeqbool_ok0 : forall x y, + NNeqbool x y = true -> x = y. +unfold NNeqbool in |- *. +intros. +assert (Neq_bool (fst x) (fst y) = true). + generalize H. + case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial. + assert (Neq_bool (snd x) (snd y) = true). + rewrite H0 in H; simpl in |- *; trivial. + generalize H0 H1. + destruct x; destruct y; simpl in |- *. + intros. + replace n with n1. + replace n2 with n0; trivial. + apply Neq_bool_ok; trivial. + symmetry in |- *. + apply Neq_bool_ok; trivial. +Qed. + + +(*gen_phiN satisfies morphism specifications*) + Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req + (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN. + 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 NSTARMORPHISM. +*) + + (* syntaxification of constants in an abstract ring *) + 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 + | ?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. + + 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. + + 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. +(* coefs = Z (abstract ring) *) +Module Zpol. + +Definition ring_gen_correct + R rO rI radd rmul rsub ropp req rSet req_th Rth := + @ring_correct R rO rI radd rmul rsub ropp req rSet req_th + (Rth_ARth rSet req_th Rth) + Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool + (@gen_phiZ R rO rI radd rmul ropp) + (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). + +Definition ring_rw_gen_correct + R rO rI radd rmul rsub ropp req rSet req_th Rth := + @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th + (Rth_ARth rSet req_th Rth) + Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool + (@gen_phiZ R rO rI radd rmul ropp) + (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). + +Definition ring_rw_gen_correct' + R rO rI radd rmul rsub ropp req rSet req_th Rth := + @Pphi_dev_ok' R rO rI radd rmul rsub ropp req rSet req_th + (Rth_ARth rSet req_th Rth) + Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool + (@gen_phiZ R rO rI radd rmul ropp) + (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). + +Definition ring_gen_eq_correct R rO rI radd rmul rsub ropp Rth := + @ring_gen_correct + R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. + +Definition ring_rw_gen_eq_correct R rO rI radd rmul rsub ropp Rth := + @ring_rw_gen_correct + R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. + +Definition ring_rw_gen_eq_correct' R rO rI radd rmul rsub ropp Rth := + @ring_rw_gen_correct' + R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. + +End Zpol. + +(* coefs = N (abstract semi-ring) *) +Module Npol. + +Definition ring_gen_correct + R rO rI radd rmul req rSet req_th SRth := + @ring_correct R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet + (SReqe_Reqe req_th) + (SRth_ARth rSet SRth) + N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool + (@gen_phiN R rO rI radd rmul) + (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). + +Definition ring_rw_gen_correct + R rO rI radd rmul req rSet req_th SRth := + @Pphi_dev_ok R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet + (SReqe_Reqe req_th) + (SRth_ARth rSet SRth) + N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool + (@gen_phiN R rO rI radd rmul) + (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). + +Definition ring_rw_gen_correct' + R rO rI radd rmul req rSet req_th SRth := + @Pphi_dev_ok' R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet + (SReqe_Reqe req_th) + (SRth_ARth rSet SRth) + N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool + (@gen_phiN R rO rI radd rmul) + (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). + +Definition ring_gen_eq_correct R rO rI radd rmul SRth := + @ring_gen_correct + R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. + +Definition ring_rw_gen_eq_correct R rO rI radd rmul SRth := + @ring_rw_gen_correct + R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. + +Definition ring_rw_gen_eq_correct' R rO rI radd rmul SRth := + @ring_rw_gen_correct' + R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. + +End Npol. + +(* Z *) + +Ltac isZcst t := + match t with + Z0 => constr:true + | Zpos ?p => isZcst p + | Zneg ?p => isZcst p + | xI ?p => isZcst p + | xO ?p => isZcst p + | xH => constr:true + | _ => constr:false + end. +Ltac Zcst t := + match isZcst t with + true => t + | _ => NotConstant + end. + +Add New Ring Zr : Zth Computational Zeqb_ok Constant Zcst. + +(* N *) + +Ltac isNcst t := + match t with + N0 => constr:true + | Npos ?p => isNcst p + | xI ?p => isNcst p + | xO ?p => isNcst p + | xH => constr:true + | _ => constr:false + end. +Ltac Ncst t := + match isNcst t with + true => t + | _ => NotConstant + end. + +Add New Ring Nr : Nth Computational Neq_bool_ok Constant Ncst. + +(* nat *) + +Ltac isnatcst t := + match t with + O => true + | S ?p => isnatcst p + | _ => false + end. +Ltac natcst t := + match isnatcst t with + true => t + | _ => NotConstant + end. + + 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. + + +Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := + match n, m with + | O, O => true + | S n', S m' => nateq n' m' + | _, _ => false + end. + +Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m. +Proof. + simple induction n; simple induction m; simpl; intros; try discriminate. + trivial. + rewrite (H n1 H1). + trivial. +Qed. + +Add New Ring natr : natSRth Computational nateq_ok Constant natcst. + diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 new file mode 100644 index 00000000..7041d7e8 --- /dev/null +++ b/contrib/setoid_ring/newring.ml4 @@ -0,0 +1,525 @@ +(************************************************************************) +(* 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 7974 2006-02-01 19:02:09Z barras $ i*) + +open Pp +open Util +open Names +open Term +open Closure +open Environ +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 Ppconstr +open Mod_subst +open Tacinterp +open Libobject +open Printer + +(****************************************************************************) +(* Library linking *) + +let contrib_name = "setoid_ring" + + +let ring_dir = ["Coq";contrib_name] +let setoids_dir = ["Coq";"Setoids"] +let ring_modules = + [ring_dir@["BinList"];ring_dir@["Ring_th"];ring_dir@["Pol"]; + ring_dir@["Ring_tac"];ring_dir@["ZRing_th"]] +let stdlib_modules = [setoids_dir@["Setoid"]] + +let coq_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) +let ring_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" ring_modules c) +let ringtac_constant m c = + lazy (Coqlib.gen_constant_in_modules "Ring" [ring_dir@["ZRing_th";m]] 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 ["ZRing_th";contrib_name;"Coq"]) +let zltac s = + lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) +let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) + +let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; +let pol_cst s = mk_cst [contrib_name;"Pol"] s ;; + +let ic c = + let env = Global.env() and sigma = Evd.empty in + Constrintern.interp_constr sigma env c + + +(* Ring theory *) + +(* almost_ring defs *) +let coq_almost_ring_theory = ring_constant "almost_ring_theory" +let coq_ring_lemma1 = ring_constant "ring_correct" +let coq_ring_lemma2 = ring_constant "Pphi_dev_ok'" +let ring_comp1 = ring_constant "ring_id_correct" +let ring_comp2 = ring_constant "ring_rw_id_correct'" +let ring_abs1 = ringtac_constant "Zpol" "ring_gen_correct" +let ring_abs2 = ringtac_constant "Zpol" "ring_rw_gen_correct'" +let sring_abs1 = ringtac_constant "Npol" "ring_gen_correct" +let sring_abs2 = ringtac_constant "Npol" "ring_rw_gen_correct'" + +(* setoid and morphism utilities *) +let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" +let coq_eq_setoid = ring_constant "Eqsth" +let coq_eq_morph = ring_constant "Eq_ext" + +(* ring -> almost_ring utilities *) +let coq_ring_theory = ring_constant "ring_theory" +let coq_ring_morph = ring_constant "ring_morph" +let coq_Rth_ARth = ring_constant "Rth_ARth" +let coq_mk_reqe = ring_constant "mk_reqe" + +(* semi_ring -> almost_ring utilities *) +let coq_semi_ring_theory = ring_constant "semi_ring_theory" +let coq_SRth_ARth = ring_constant "SRth_ARth" +let coq_sring_morph = ring_constant "semi_morph" +let coq_SRmorph_Rmorph = ring_constant "SRmorph_Rmorph" +let coq_mk_seqe = ring_constant "mk_seqe" +let coq_SRsub = ring_constant "SRsub" +let coq_SRopp = ring_constant "SRopp" +let coq_SReqe_Reqe = ring_constant "SReqe_Reqe" + +let ltac_setoid_ring = ltac"Make_ring_tac" +let ltac_setoid_ring_rewrite = ltac"Make_ring_rw_list" +let ltac_inv_morphZ = zltac"inv_gen_phiZ" +let ltac_inv_morphN = zltac"inv_gen_phiN" + +let coq_cons = ring_constant "cons" +let coq_nil = ring_constant "nil" + +let lapp f args = mkApp(Lazy.force f,args) + +let dest_rel t = + match kind_of_term t with + App(f,args) when Array.length args >= 2 -> + mkApp(f,Array.sub args 0 (Array.length args - 2)) + | _ -> failwith "cannot find relation" + +(****************************************************************************) +(* 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 i c = + match map i with + Eval -> inject c + | Prot -> mk_atom c + | Rec -> if i = -1 then inject c else tag_rec c + +let rec mk_clos_but f_map t = + match f_map t with + | Some map -> tag_arg (mk_clos_but f_map) map (-1) t + | None -> + (match kind_of_term t with + App(f,args) -> mk_clos_app_but f_map f args 0 + (* unspecified constants are evaluated *) + | _ -> inject t) + +and mk_clos_app_but f_map f args n = + if n >= Array.length args then inject(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 _ -> unmark_arg (tag_arg (mk_clos_but f_map) map)) + (Esubst.ESID 0) + (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) + | None -> mk_clos_app_but f_map 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 arg_map = + [mk_cst [contrib_name;"BinList"] "cons",(function -1->Eval|2->Rec|_->Prot); + mk_cst [contrib_name;"BinList"] "nil", (function -1->Eval|_ -> Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect + ring operations and make recursive call on morphism and var map *) + pol_cst "Pphi_dev", (function -1|6|7|8|11->Eval|9|10->Rec|_->Prot); + (* PEeval: evaluate polynomial, protect ring operations + and make recursive call on morphism and var map *) + pol_cst "PEeval", (function -1|9->Eval|7|8->Rec|_->Prot); + (* Do not evaluate ring operations... *) + ring_constant "gen_phiZ", (function -1|6->Eval|_->Prot); + ring_constant "gen_phiN", (function -1|5->Eval|_->Prot); +];; + +(* Equality: do not evaluate but make recursive call on both sides *) +let is_ring_thm req = + interp_map + ((req,(function -1->Prot|_->Rec)):: + List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) +;; + +let protect_red env sigma c = + let req = dest_rel c in + kl (create_clos_infos betadeltaiota env) + (mk_clos_but (is_ring_thm req) c);; + +let protect_tac = + Tactics.reduct_option (protect_red,DEFAULTcast) None ;; + +let protect_tac_in id = + Tactics.reduct_option (protect_red,DEFAULTcast) (Some(id,[],InHyp));; + + +TACTIC EXTEND protect_fv + [ "protect_fv" "in" ident(id) ] -> + [ protect_tac_in id ] +| [ "protect_fv" ] -> + [ protect_tac ] +END;; + +(****************************************************************************) +(* Ring database *) + +let ty c = Typing.type_of (Global.env()) Evd.empty c + + +type ring_info = + { ring_carrier : types; + ring_req : constr; + ring_cst_tac : glob_tactic_expr; + ring_lemma1 : constr; + ring_lemma2 : constr } + +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 _ = + Summary.declare_summary "tactic-new-ring-table" + { Summary.freeze_function = (fun () -> !from_carrier,!from_relation); + Summary.unfreeze_function = + (fun (ct,rt) -> from_carrier := ct; from_relation := rt); + Summary.init_function = + (fun () -> from_carrier := Cmap.empty; from_relation := Cmap.empty); + Summary.survive_module = false; + Summary.survive_section = false } + +let add_entry _ 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 + + +let subst_th (_,subst,th) = + let c' = subst_mps subst th.ring_carrier in + let eq' = subst_mps subst th.ring_req 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 + if c' == th.ring_carrier && + eq' == th.ring_req && + thm1' == th.ring_lemma1 && + thm2' == th.ring_lemma2 && + tac' == th.ring_cst_tac then th + else + { ring_carrier = c'; + ring_req = eq'; + ring_cst_tac = tac'; + ring_lemma1 = thm1'; + ring_lemma2 = thm2' } + + +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 ring_for_carrier r = Cmap.find r !from_carrier + +let ring_for_relation rel = Cmap.find rel !from_relation + +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_SReqe_Reqe + [| r;add;mul;req;lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]|] + +let sr_sub r add = lapp coq_SRsub [|r;add|] +let sr_opp r = lapp coq_SRopp [|r|] + +let dest_morphism kind th sth = + let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in + match kind_of_term th_typ with + App(f,[|_;_;_;_;_;_;_;_;c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) + when f = Lazy.force coq_ring_morph -> + (th,[|c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) + | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) + when f = Lazy.force coq_sring_morph && kind=Some true-> + let th = + lapp coq_SRmorph_Rmorph + [|r;zero;one;add;mul;req;sth;c;czero;cone;cadd;cmul;ceqb;phi;th|]in + (th,[|c;czero;cone;cadd;cmul;cadd;sr_opp c;ceqb;phi|]) + | _ -> failwith "bad ring_morph lemma" + +let dest_eq_test th = + let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in + match decompose_prod th_typ with + (_,h)::_,_ -> + (match snd(destApplication h) with + [|_;lhs;_|] -> fst(destApplication lhs) + | _ -> failwith "bad lemma for decidability of equality") + | _ -> failwith "bad lemma for decidability of equality" + +let default_ring_equality is_semi (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 = lapp coq_eq_morph [|r;add;mul;opp|] 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 = + if is_semi <> Some true then + (let opp_m = default_morphism ~filter:is_endomorphism opp 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) + else + (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 is_semi r add mul opp req eqth = + match eqth with + Some th -> th + | None -> default_ring_equality is_semi (r,add,mul,opp,req) + +let dest_ring th_spec = + let th_typ = Retyping.get_type_of (Global.env()) Evd.empty 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,sub,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,sr_sub r add,sr_opp r,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,sub,opp,req) + | _ -> error "bad ring structure" + + +let build_almost_ring kind r zero one add mul sub opp req sth morph th = + match kind with + None -> th + | Some true -> + lapp coq_SRth_ARth [|r;zero;one;add;mul;req;sth;th|] + | Some false -> + lapp coq_Rth_ARth [|r;zero;one;add;mul;sub;opp;req;sth;morph;th|] + + +type coeff_spec = + Computational of constr (* equality test *) + | Abstract (* coeffs = Z *) + | Morphism of constr (* general morphism *) + +type cst_tac_spec = + CstTac of raw_tactic_expr + | Closed of constr list + + +let add_theory name rth eqth morphth cst_tac = + Coqlib.check_required_library ["Coq";"setoid_ring";"Ring_tac"]; + let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring rth in + let (sth,morph) = build_setoid_params kind r add mul opp req eqth in + let args0 = [|r;zero;one;add;mul;sub;opp;req;sth;morph|] in + let (lemma1,lemma2) = + match morphth with + | Computational c -> + let reqb = dest_eq_test c in + let rth = + build_almost_ring + kind r zero one add mul sub opp req sth morph rth in + let args = Array.append args0 [|rth;reqb;c|] in + (lapp ring_comp1 args, lapp ring_comp2 args) + | Morphism m -> + let (m,args1) = dest_morphism kind m sth in + let rth = + build_almost_ring + kind r zero one add mul sub opp req sth morph rth in + let args = Array.concat [args0;[|rth|]; args1; [|m|]] in + (lapp coq_ring_lemma1 args, lapp coq_ring_lemma2 args) + | Abstract -> + Coqlib.check_required_library ["Coq";"setoid_ring";"ZRing_th"]; + let args1 = Array.append args0 [|rth|] in + (match kind with + None -> error "an almost_ring cannot be abstract" + | Some true -> + (lapp sring_abs1 args1, lapp sring_abs2 args1) + | Some false -> + (lapp ring_abs1 args1, lapp ring_abs2 args1)) in + let cst_tac = match cst_tac with + Some (CstTac t) -> Tacinterp.glob_tactic t + | Some (Closed lc) -> failwith "TODO" + | None -> + (match kind with + Some true -> + let t = Genarg.ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in + TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) + | Some false -> + let t = Genarg.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") in + let _ = + Lib.add_leaf name + (theory_to_obj + { ring_carrier = r; + ring_req = req; + ring_cst_tac = cst_tac; + ring_lemma1 = lemma1; + ring_lemma2 = lemma2 }) in + () + +VERNAC ARGUMENT EXTEND ring_coefs +| [ "Computational" constr(c)] -> [ Computational (ic c) ] +| [ "Abstract" ] -> [ Abstract ] +| [ "Coefficients" constr(m)] -> [ Morphism (ic m) ] +| [ ] -> [ Abstract ] +END + +VERNAC ARGUMENT EXTEND ring_cst_tac +| [ "Constant" tactic(c)] -> [ Some(CstTac c) ] +| [ "[" ne_constr_list(l) "]" ] -> [ Some(Closed (List.map ic l)) ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND AddSetoidRing +| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c) + "Setoid" constr(e) constr(m) ring_cst_tac(tac) ] -> + [ add_theory id (ic t) (Some (ic e, ic m)) c tac ] +| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c) + ring_cst_tac(tac) ] -> + [ add_theory id (ic t) None c tac ] +END + + +(*****************************************************************************) +(* The tactics consist then only in a lookup in the ring database and + call the appropriate ltac. *) + +let ring gl = + let req = dest_rel (pf_concl gl) in + let e = + 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"\"") in + Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, + Genarg.ArgArg(dummy_loc, Lazy.force ltac_setoid_ring), + Tacexp e.ring_cst_tac:: + List.map carg [e.ring_lemma1;e.ring_lemma2;e.ring_req]))) + gl + +let ring_rewrite rl = + let ty = Retyping.get_type_of (Global.env()) Evd.empty (List.hd rl) in + let e = + try ring_for_carrier ty + with Not_found -> + errorlabstrm "ring" + (str"cannot find a declared ring structure over"++ + spc()++str"\""++pr_constr ty++str"\"") in + let rl = List.fold_right (fun x l -> lapp coq_cons [|ty;x;l|]) rl + (lapp coq_nil [|ty|]) in + Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, + Genarg.ArgArg(dummy_loc, Lazy.force ltac_setoid_ring_rewrite), + Tacexp e.ring_cst_tac::List.map carg [e.ring_lemma2;e.ring_req;rl]))) + +let setoid_ring = function + | [] -> ring + | l -> ring_rewrite l + +TACTIC EXTEND setoid_ring + [ "setoid" "ring" constr_list(l) ] -> [ setoid_ring l ] +END + diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v new file mode 100644 index 00000000..bbf722db --- /dev/null +++ b/contrib/subtac/FixSub.v @@ -0,0 +1,22 @@ +Require Import Wf. + +Section Well_founded. +Variable A : Set. +Variable R : A -> A -> Prop. +Hypothesis Rwf : well_founded R. + +Section FixPoint. + +Variable P : A -> Set. + +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 FixPoint. + +End Well_founded. diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v new file mode 100644 index 00000000..9acb10ae --- /dev/null +++ b/contrib/subtac/Utils.v @@ -0,0 +1,34 @@ +Set Implicit Arguments. + +Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. +intros. +induction t. +exact x. +Defined. + +Check proj1_sig. +Lemma subset_simpl : forall (A : Set) (P : A -> Prop) + (t : sig P), P (proj1_sig t). +Proof. +intros. +induction t. + simpl ; auto. +Qed. + +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 "'forall' { x : A | P } , Q" := + (forall x:{x:A|P}, Q) + (at level 200, x ident, right associativity). + +Notation "'fun' { x : A | P } => Q" := + (fun x:{x:A|P} => Q) + (at level 200, x ident, right associativity). + +Notation "( x & y )" := (@existS _ _ x y) : core_scope. 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..5703c0ef --- /dev/null +++ b/contrib/subtac/eterm.ml @@ -0,0 +1,168 @@ +(** + - 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 + 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_evars evs n t = + let evar_info id = + let rec aux i = function + (k, h, v) :: tl -> if k = id then (i, h, v) else aux (succ i) tl + | [] -> raise Not_found + in + let (idx, hyps, v) = aux 0 evs in + n + idx + 1, hyps + in + let rec substrec depth c = match kind_of_term c with + | Evar (k, args) -> + (try + let index, hyps = evar_info k in + trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ + int (List.length hyps) ++ str " hypotheses"); + + let ex = mkRel (index + depth) in + (* 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 + | _, _ -> failwith "subst_evars: invalid argument" + in aux hyps (Array.to_list args) [] + in + mkApp (ex, Array.of_list args) + with Not_found -> + anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")) + | _ -> map_constr_with_binders succ substrec depth c + in + substrec 0 t + +(** 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 De Bruijn indices. +*) +let etype_of_evar evs ev hyps = + let rec aux acc n = function + (id, copt, t) :: tl -> + let t' = subst_evars evs n t in + let t'' = subst_vars acc 0 t' in + mkNamedProd_or_LetIn (id, copt, t'') (aux (id :: acc) (succ n) tl) + | [] -> + let t' = subst_evars evs n ev.evar_concl in + subst_vars acc 0 t' + in aux [] 0 (rev hyps) + + +open Tacticals + +let eterm_term evm t tycon = + (* 'Serialize' the evars, we assume that the types of the existentials + refer to previous existentials in the list only *) + let evl = to_list evm in + let evts = + (* Remove existential variables in types and build the corresponding products *) + fold_right + (fun (id, ev) l -> + let hyps = Environ.named_context_of_val ev.evar_hyps in + let y' = (id, hyps, etype_of_evar l ev hyps) in + y' :: l) + evl [] + in + let t' = (* Substitute evar refs in the term by De Bruijn indices *) + subst_evars evts 0 t + in + let evar_names = + List.map (fun (id, _, c) -> (id_of_string ("Evar" ^ string_of_int id)), c) evts + in + let evar_bl = + List.map (fun (id, c) -> Name id, None, c) evar_names + in + let anon_evar_bl = List.map (fun (_, x, y) -> (Anonymous, x, y)) evar_bl in + (* Generalize over the existential variables *) + let t'' = Termops.it_mkLambda_or_LetIn t' evar_bl + and tycon = option_app + (fun typ -> Termops.it_mkProd_wo_LetIn typ anon_evar_bl) tycon + in + let _declare_evar (id, c) = + let id = id_of_string ("Evar" ^ string_of_int id) in + ignore(Declare.declare_variable id (Names.empty_dirpath, Declare.SectionLocalAssum c, + Decl_kinds.IsAssumption Decl_kinds.Definitional)) + in + let _declare_assert acc (id, c) = + let id = id_of_string ("Evar" ^ string_of_int id) in + tclTHEN acc (Tactics.assert_tac false (Name id) c) + in + 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(option_app + (fun typ -> + trace (str "Type :" ++ spc () ++ + Termops.print_constr_env (Global.env ()) typ)) + tycon); + t'', tycon, evar_names + +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) = eterm evm t None diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli new file mode 100644 index 00000000..fbe2ac1d --- /dev/null +++ b/contrib/subtac/eterm.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* 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 8688 2006-04-07 15:08:12Z msozeau $ i*) + +open Tacmach +open Term +open Evd +open Names + +val mkMetas : int -> constr list + +val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list + +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..c3f2a24d --- /dev/null +++ b/contrib/subtac/g_subtac.ml4 @@ -0,0 +1,62 @@ +(************************************************************************) +(* 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 8688 2006-04-07 15:08:12Z msozeau $ *) + +(*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 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" +end + +open SubtacGram +open Util + +GEXTEND Gram + GLOBAL: subtac_gallina_loc; + + subtac_gallina_loc: + [ [ g = Vernac.gallina -> loc, g ] ] + ; + END + +type gallina_loc_argtype = (Vernacexpr.vernac_expr located, constr_expr, Tacexpr.raw_tactic_expr) Genarg.abstract_argument_type + +let (wit_subtac_gallina_loc : gallina_loc_argtype), + (globwit_subtac_gallina_loc : gallina_loc_argtype), + (rawwit_subtac_gallina_loc : gallina_loc_argtype) = + Genarg.create_arg "subtac_gallina_loc" + +VERNAC COMMAND EXTEND Subtac +[ "Program" subtac_gallina_loc(g) ] -> + [ Subtac.subtac g ] +END diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml new file mode 100644 index 00000000..84b7d39b --- /dev/null +++ b/contrib/subtac/subtac.ml @@ -0,0 +1,203 @@ +(************************************************************************) +(* 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 8688 2006-04-07 15:08:12Z 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 _ = trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++ + Ppconstr.pr_constr_expr body) + 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 + + *) + +let subtac (loc, command) = + check_required_library ["Coq";"Init";"Datatypes"]; + check_required_library ["Coq";"Init";"Specif"]; + require_library "Coq.subtac.FixSub"; + require_library "Coq.subtac.Utils"; + try + match command with + VernacDefinition (defkind, (locid, id), expr, hook) -> + let env = Global.env () in + let isevars = ref (create_evar_defs Evd.empty) in + (match expr with + ProveBody (bl, c) -> + let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c None in + trace (str "Starting proof"); + Command.start_proof id goal_kind c hook; + trace (str "Started proof"); + + | DefineBody (bl, _, c, tycon) -> + let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c tycon in + 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) + (*| 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, e) -> + debug 2 (Himsg.explain_type_error env e) + + | Pretype_errors.PretypeError (env, e) -> + debug 2 (Himsg.explain_pretype_error env e) + + | Stdpp.Exc_located (loc, e) -> + debug 2 (str "Parsing exception: "); + (match e with + | Type_errors.TypeError (env, e) -> + debug 2 (Himsg.explain_type_error env e) + + | Pretype_errors.PretypeError (env, e) -> + debug 2 (Himsg.explain_pretype_error env e) + + | e -> msg_warning (str "Unexplained exception: " ++ Cerrors.explain_exn e)) + + | e -> + msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e) + + diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli new file mode 100644 index 00000000..a0d2fb2b --- /dev/null +++ b/contrib/subtac/subtac.mli @@ -0,0 +1,14 @@ +val require_library : string -> unit +val subtac_one_fixpoint : + 'a -> + 'b -> + (Names.identifier * (int * Topconstr.recursion_order_expr) * + Topconstr.local_binder list * Topconstr.constr_expr * + Topconstr.constr_expr) * + 'c -> + (Names.identifier * (int * Topconstr.recursion_order_expr) * + Topconstr.local_binder list * Topconstr.constr_expr * + Topconstr.constr_expr) * + 'c +val subtac_fixpoint : 'a -> 'b -> unit +val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml new file mode 100644 index 00000000..7c8ea2d6 --- /dev/null +++ b/contrib/subtac/subtac_coercion.ml @@ -0,0 +1,485 @@ +(************************************************************************) +(* 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 8695 2006-04-10 16:33:52Z 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 = + trace (str "Disc_exist: " ++ my_print_constr 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 = + trace (str "disc_proj_exist: " ++ my_print_constr 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 rec aux v = + 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, t) + 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 + trace (str "Coerce called for " ++ (my_print_constr env x) ++ + str " and "++ my_print_constr env y ++ + str " with evars: " ++ spc () ++ + my_print_evardefs !isevars); + let rec coerce_unify env x y = + trace (str "coerce_unify from " ++ (my_print_constr env x) ++ + str " to "++ my_print_constr env y); + try + isevars := the_conv_x_leq env x y !isevars; + trace (str "Unified " ++ (my_print_constr env x) ++ + str " and "++ my_print_constr env y); + 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 + trace (str "coerce' from " ++ (my_print_constr env x) ++ + str " to "++ my_print_constr env y); + 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 c1 = coerce_unify env a' a in + let env' = push_rel (name', None, a') env 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' + then + if i = Term.destInd existS.typ + then + begin + debug 1 (str "In coerce sigma types"); + 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 -> + trace (str "No coercion needed"); + 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 if i = Term.destInd prod.typ then + begin + debug 1 (str "In coerce prod types"); + 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 subco () + else subco () + | _ -> subco ()) + | _, _ -> subco () + + and subset_coerce env isevars x y = + match disc_subset x with + Some (u, p) -> + let c = coerce_unify env u y in + let f x = + app_opt c (mkApp ((Lazy.force sig_).proj1, + [| u; p; x |])) + in Some f + | None -> + match disc_subset y with + Some (u, p) -> + let c = coerce_unify env x u in + Some + (fun x -> + let cx = app_opt c x in + let evar = make_existential 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_app (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_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 + trace (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 () ++ + Evd.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_app (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_app (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_app (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_app (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 () ++ + Evd.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 + let (rels, rng) = + (* a little more effort to get products is needed *) + try decompose_prod_n nabs t + with _ -> + trace (str "decompose_prod_n failed"); + raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") + 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 +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..1b92c691 --- /dev/null +++ b/contrib/subtac/subtac_command.ml @@ -0,0 +1,422 @@ +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 + +(*********************************************************************) +(* 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_interp_fixpoint.rewrite_cases env c' in + msgnl (str "Pretyping " ++ my_print_constr_expr c); + 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) + | _ -> 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 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") + +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 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 build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed = + let sigma = Evd.empty + and env0 = Global.env() + in + let lnameargsardef = + (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env0 protos (f, d))*) + lnameargsardef + 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_impls,arityl) = + List.fold_left + (fun (env,impls,arl) ((recname,(n, ro),bl,arityc,body),_) -> + let isevars = ref (Evd.create_evar_defs sigma) in + match ro with + CStructRec -> + let arityc = Command.generalize_constr_expr arityc bl in + let arity = interp_type isevars env0 arityc in + let impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits env0 arity + else [] in + let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in + (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl) + | CWfRec r -> + let _ = trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ + Ppconstr.pr_binders bl ++ str " : " ++ + Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ + Ppconstr.pr_constr_expr body) + in + let env', binders_rel = interp_context isevars env0 bl in + let after, ((argname, _, argtyp) as arg), before = list_chop_hd n binders_rel in + let argid = match argname with Name n -> n | _ -> assert(false) in + let after' = List.map (fun (n, c, t) -> (n, option_app (lift 1) c, lift 1 t)) after in + let envwf = push_rel_context before env0 in + let wf_rel = interp_constr isevars envwf r in + let accarg_id = id_of_string ("Acc_" ^ string_of_id argid) in + let accarg = (Name accarg_id, None, mkApp (Lazy.force acc_inv, [| argtyp; wf_rel; mkRel 1 |])) in + let argid' = id_of_string (string_of_id argid ^ "'") in + let before_length, after_length = List.length before, List.length after in + let full_length = before_length + 1 + after_length in + let wfarg len = (Name argid, None, + mkSubset (Name argid') argtyp + (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|]))) + in + let new_bl = after' @ (accarg :: arg :: before) + and intern_bl = after @ (wfarg (before_length + 1) :: before) + in + let intern_env = push_rel_context intern_bl env0 in + let env' = push_rel_context new_bl env0 in + let arity = interp_type isevars intern_env arityc in + let intern_arity = it_mkProd_or_LetIn arity intern_bl in + let arity' = interp_type isevars env' arityc in + let arity' = it_mkProd_or_LetIn arity' new_bl in + let fun_bl = after @ ((Name recname, None, intern_arity) :: arg :: before) in + let _ = + let pr c = my_print_constr env c in + let prr = Printer.pr_rel_context env in + trace (str "Fun bl: " ++ prr fun_bl ++ spc () ++ + str "Intern bl" ++ prr intern_bl ++ spc () ++ + str "Extern bl" ++ prr new_bl ++ spc () ++ + str "Intern arity: " ++ pr intern_arity) + in + let impl = + if Impargs.is_implicit_args() + then Impargs.compute_implicits intern_env arity' + else [] in + let impls' = (recname,([],impl,compute_arguments_scope arity'))::impls in + (Environ.push_named (recname,None,arity') env, impls', + (isevars, Some (full_length - n, argtyp, wf_rel, fun_bl, intern_bl, intern_arity), arity')::arl)) + (env0,[],[]) 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_sign ~impls:([],rec_impls) + def arity + | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) -> + let rec_sign = push_rel_context fun_bl rec_sign in + let cstr = interp_casted_constr isevars rec_sign ~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 env0 lrecnames recdef arityl nv in + let nvrec' = Array.map fst nvrec in(* ignore rec order *) + let declare arrec defrec = + let recvec = + Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in + let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in + let rec declare i fi = + trace (str "Declaring: " ++ pr_id fi ++ spc () ++ + my_print_constr env0 (recvec.(i))); + let ce = + { const_entry_body = mkFix ((nvrec',i),recdecls); + const_entry_type = Some arrec.(i); + const_entry_opaque = false; + const_entry_boxed = boxed} in + let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint) + in (ConstRef kn) + in + (* declare the recursive definitions *) + let lrefrec = Array.mapi declare namerec in + Options.if_verbose ppnl (recursive_message lrefrec); + + + (*(* The others are declared as normal definitions *) + let var_subst id = (id, Constrintern.global_reference id) in + let _ = + List.fold_left + (fun subst (f,def,t) -> + let ce = { const_entry_body = replace_vars subst def; + const_entry_type = Some t; + const_entry_opaque = false; + const_entry_boxed = boxed } in + let _ = + Declare.declare_constant f (DefinitionEntry ce,IsDefinition Definition) + in + warning ((string_of_id f)^" is non-recursively defined"); + (var_subst f) :: subst) + (List.map var_subst (Array.to_list namerec)) + lnonrec + in*) + List.iter (fun (df,c,scope) -> + Metasyntax.add_notation_interpretation df [] c scope) notations + in + let declare l = + let recvec = Array.of_list l + and arrec = Array.map pi3 arrec + in declare arrec recvec + in + let recdefs = Array.length defrec in + trace (int recdefs ++ str " recursive definitions"); + (* Solve remaining evars *) + let rec collect_evars i acc = + if i < recdefs then + let (isevars, info, def) = defrec.(i) in + let _ = trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) in + let def = evar_nf isevars def in + let isevars = Evd.undefined_evars !isevars in + let _ = trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) in + let evm = Evd.evars_of isevars in + let _, _, typ = arrec.(i) in + let id = namerec.(i) in + let evars_def, evars_typ, evars = Eterm.eterm_term evm def (Some typ) in + (* Generalize by the recursive prototypes *) + let def = + Termops.it_mkNamedLambda_or_LetIn def (Environ.named_context rec_sign) + and typ = + Termops.it_mkNamedProd_or_LetIn typ (Environ.named_context rec_sign) + in + (*let evars_typ = match evars_typ with Some t -> t | None -> assert(false) in*) + (*let fi = id_of_string (string_of_id id ^ "_evars") in*) + (*let ce = + { const_entry_body = evars_def; + const_entry_type = Some evars_typ; + const_entry_opaque = false; + const_entry_boxed = boxed} in + let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Definition) in + definition_message fi; + trace (str (string_of_id fi) ++ str " is defined");*) + let evar_sum = + if evars = [] then None + else + let sum = Subtac_utils.build_dependent_sum evars in + trace (str "Evars sum: " ++ my_print_constr env0 (pi1 sum)); + Some sum + in + collect_evars (succ i) ((id, evars_def, evar_sum) :: acc) + else acc + in + let defs = collect_evars 0 [] in + + (* Solve evars then create the definitions *) + let real_evars = + filter_map (fun (id, kn, sum) -> + match sum with Some (sumg, sumtac, _) -> Some (id, kn, sumg, sumtac) | None -> None) + defs + in + Subtac_utils.and_tac real_evars + (fun f _ gr -> + let _ = trace (str "Got a proof of: " ++ pr_global gr) in + let constant = match gr with Libnames.ConstRef c -> c + | _ -> assert(false) + in + try + (*let value = Environ.constant_value (Global.env ()) constant in*) + let pis = f (mkConst constant) in + trace (str "Accessors: " ++ + List.fold_right (fun (_, _, _, c) acc -> my_print_constr env0 c ++ spc () ++ acc) + pis (mt())); + trace (str "Applied existentials: " ++ + (List.fold_right + (fun (id, kn, sumg, pi) acc -> + let args = Subtac_utils.destruct_ex pi sumg in + my_print_constr env0 (mkApp (kn, Array.of_list args))) + pis (mt ()))); + let rec aux pis acc = function + (id, kn, sum) :: tl -> + (match sum with + None -> aux pis (kn :: acc) tl + | Some (sumg, _, _) -> + let (id, kn, sumg, pi), pis = List.hd pis, List.tl pis in + let args = Subtac_utils.destruct_ex pi sumg in + let args = + List.map (fun c -> + try Reductionops.whd_betadeltaiota (Global.env ()) Evd.empty c + with Not_found -> + trace (str "Not_found while reducing " ++ + my_print_constr (Global.env ()) c); + c + ) args + in + let _, newdef = decompose_lam_n (recdefs + List.length args) kn in + let constr = Term.substl (mkRel 1 :: List.rev args) newdef in + aux pis (constr :: acc) tl) + | [] -> List.rev acc + in + declare (aux pis [] defs) + with Environ.NotEvaluableConst cer -> + match cer with + Environ.NoBody -> trace (str "Constant has no body") + | Environ.Opaque -> trace (str "Constant is opaque") + ) + + diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli new file mode 100644 index 00000000..e1bbbbb5 --- /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 recursive_message : global_reference array -> std_ppcmds +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..599dbe39 --- /dev/null +++ b/contrib/subtac/subtac_interp_fixpoint.ml @@ -0,0 +1,219 @@ +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, 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 + +let list_mapi f = + let rec aux i = function + hd :: tl -> f i hd :: aux (succ i) tl + | [] -> [] + in aux 0 + +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 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 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' diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli new file mode 100644 index 00000000..b0de0641 --- /dev/null +++ b/contrib/subtac/subtac_interp_fixpoint.mli @@ -0,0 +1,39 @@ +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 +val rewrite_fixpoint : + 'a -> + 'b -> + (Names.identifier * (int * Topconstr.recursion_order_expr) * + Topconstr.local_binder list * Topconstr.constr_expr * + Topconstr.constr_expr) * + 'c -> + (Names.identifier * (int * Topconstr.recursion_order_expr) * + Topconstr.local_binder list * Topconstr.constr_expr * + Topconstr.constr_expr) * + 'c +val list_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list +val rewrite_cases_aux : + Util.loc * Rawterm.rawconstr option * + (Rawterm.rawconstr * + (Names.name * (Util.loc * Names.inductive * Names.name list) option)) + list * + (Util.loc * Names.identifier list * Rawterm.cases_pattern list * + Rawterm.rawconstr) + list -> Rawterm.rawconstr + +val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml new file mode 100644 index 00000000..104a0a58 --- /dev/null +++ b/contrib/subtac/subtac_pretyping.ml @@ -0,0 +1,150 @@ +(************************************************************************) +(* 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 8688 2006-04-07 15:08:12Z 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 = Pretyping.Pretyping_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 evars () = evars_of !isevars in + let _ = trace (str "Creating env with binders") in + let env_binders, binders_rel = env_with_binders env isevars l in + let _ = trace (str "New env created:" ++ my_print_context env_binders) in + let tycon = + match tycon with + None -> empty_tycon + | Some t -> + let t = coqintern !isevars env_binders t in + let _ = trace (str "Internalized specification: " ++ my_print_rawconstr env_binders t) in + let coqt, ttyp = interp env_binders isevars t empty_tycon in + let _ = trace (str "Interpreted type: " ++ my_print_constr env_binders coqt) in + mk_tycon coqt + in + let c = coqintern !isevars env_binders c in + let _ = trace (str "Internalized term: " ++ my_print_rawconstr env c) in + let coqc, ctyp = interp env_binders isevars c tycon in + let _ = trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ + str "Coq type: " ++ my_print_constr env_binders ctyp) + in + let _ = trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) 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 _ = trace (str "After evar normalization: " ++ spc () ++ + str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () + ++ str "Coq type: " ++ my_print_constr env fullctyp) + in + let evm = non_instanciated_map env isevars in + let _ = trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) in + evm, fullcoqc, fullctyp diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli new file mode 100644 index 00000000..97e56ecb --- /dev/null +++ b/contrib/subtac/subtac_pretyping.mli @@ -0,0 +1,12 @@ +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 diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml new file mode 100644 index 00000000..6c165dad --- /dev/null +++ b/contrib/subtac/subtac_utils.ml @@ -0,0 +1,246 @@ +open Evd +open Libnames +open Coqlib +open Term +open Names +open Util + +(****************************************************************************) +(* 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 s = Qualid (dummy_loc, (qualid_of_string 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 "Coq.subtac.FixSub.Fix_sub" +let lt_wf_ref = make_ref "Coq.Wf_nat.lt_wf" +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 eqind = lazy (init_constant ["Init"; "Logic"] "eq") +let eqind_ref = lazy (init_reference ["Init"; "Logic"] "eq") +let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") + +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_set ()) + +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_context = Termops.print_rel_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 n s = + if !Options.debug then + msgnl s + else () + +let debug_msg n s = + if !Options.debug then s + else mt () + +let trace s = + if !Options.debug then msgnl s + 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 + debug 2 (str "Constructed evar " ++ int key ++ str " applied to args: " ++ + print_args env args); + 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_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 build_dependent_sum l = + let rec aux (acc, tac, typ) = function + (n, t) :: tl -> + let t' = mkLambda (Name n, t, typ) in + trace (str ("treating " ^ string_of_id n) ++ + str "assert: " ++ my_print_constr (Global.env ()) t); + let tac' = + tclTHEN (assert_tac true (Name n) t) + (tclTHENLIST + [intros; + (tclTHENSEQ + [tclTRY (constructor_tac (Some 1) 1 + (Rawterm.ImplicitBindings [mkVar n])); + tac]); + ]) + in + aux (mkApp (Lazy.force ex_ind, [| t; t'; |]), tac', t') tl + | [] -> acc, tac, typ + in + match l with + (_, hd) :: tl -> aux (hd, intros, hd) tl + | [] -> raise (Invalid_argument "build_dependent_sum") + +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 + (mk_ex_pi1 dom rng acc) :: aux rng (mk_ex_pi2 dom rng acc) + | _ -> [acc]) + | _ -> [acc] + in aux ex ext + + diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli new file mode 100644 index 00000000..92a995c8 --- /dev/null +++ b/contrib/subtac/subtac_utils.mli @@ -0,0 +1,85 @@ +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 + +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 make_ref : string -> reference +val well_founded_ref : reference +val acc_ref : reference +val acc_inv_ref : reference +val fix_sub_ref : reference +val lt_wf_ref : reference +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 eqind : constr lazy_t +val eqind_ref : global_reference lazy_t +val refl_equal_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_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_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 -> constr * 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 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..bac7ad7c 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -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 -> + 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.library_part (LN.ConstRef con) + | Inductive kn -> + N.id_of_label (N.label kn), Lib.library_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 = @@ -229,10 +242,10 @@ let typeur sigma metamap = | 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) + | 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..518f6c11 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.map sigma n).Evd.evar_hyps in let rec iter actual_args evar_context = match actual_args,evar_context with [],[] -> () @@ -124,10 +125,10 @@ let double_type_of env sigma cstr expectedty subterms_to_types = E.make_judge cstr (E.constant_type 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..dff546c9 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)) + 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)) -> @@ -93,7 +93,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 @@ -117,34 +117,39 @@ let extract_open_proof sigma pf = (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 +157,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..578c1ed2 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*) *) ;; @@ -95,7 +96,7 @@ let string_of_prim_rule x = match x with 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 = @@ -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,11 +181,12 @@ 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)} -> 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..871a7f15 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,11 +395,11 @@ 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 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 @@ -406,7 +409,7 @@ let mk_inductive_obj sp packs variables hyps finite = D.mind_typename=typename ; D.mind_nf_arity=arity} = p in - let lc = Inductive.arities_of_constructors (Global.env ()) (sp,!tyno) 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_structure 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,23 @@ 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 + Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Ln.IndRef (kn,_) -> - let {D.mind_packets=packs ; + 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 + Cic2acic.Inductive kn,mk_inductive_obj kn packs variables nparams hyps finite | Ln.ConstructRef _ -> Util.anomaly ("print: this should not happen") 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 ;; @@ -558,18 +556,19 @@ let show_pftreestate internal fn (kind,pftst) id = 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;; |